From: William Harold Newman Date: Thu, 14 Jul 2005 18:56:58 +0000 (+0000) Subject: 0.9.2.47: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git 0.9.2.47: another slice of whitespace canonicalization (Anyone who ends up here with "cvs annotate" probably wants to look at the "tabby" tagged version.) --- diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index b7d8630..c203447 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -42,9 +42,9 @@ ;;; 2. This function is in a potential bottleneck for the compiler, ;;; and avoiding the general TYPECASE lets us improve performance ;;; because -;;; 2a. the general TYPECASE is intrinsically slow, and -;;; 2b. the general TYPECASE is too big for us to easily afford -;;; to inline it, so it brings with it a full function call. +;;; 2a. the general TYPECASE is intrinsically slow, and +;;; 2b. the general TYPECASE is too big for us to easily afford +;;; to inline it, so it brings with it a full function call. ;;; ;;; Why not specialize instead of optimize? (I.e. why fall through to ;;; general SXHASH as a last resort?) Because the INFO database is used @@ -55,18 +55,18 @@ #!-sb-fluid (declaim (inline globaldb-sxhashoid)) (defun globaldb-sxhashoid (x) (logand sb!xc:most-positive-fixnum - (cond ((symbolp x) (sxhash x)) - ((and (listp x) - (eq (first x) 'setf) - (let ((rest (rest x))) - (and (symbolp (car rest)) - (null (cdr rest))))) - ;; We need to declare the type of the value we're feeding to - ;; SXHASH so that the DEFTRANSFORM on symbols kicks in. - (let ((symbol (second x))) - (declare (symbol symbol)) - (logxor (sxhash symbol) 110680597))) - (t (sxhash x))))) + (cond ((symbolp x) (sxhash x)) + ((and (listp x) + (eq (first x) 'setf) + (let ((rest (rest x))) + (and (symbolp (car rest)) + (null (cdr rest))))) + ;; We need to declare the type of the value we're feeding to + ;; SXHASH so that the DEFTRANSFORM on symbols kicks in. + (let ((symbol (second x))) + (declare (symbol symbol)) + (logxor (sxhash symbol) 110680597))) + (t (sxhash x))))) ;;; Given any non-negative integer, return a prime number >= to it. ;;; @@ -114,12 +114,12 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defstruct (class-info - (:constructor make-class-info (name)) - #-no-ansi-print-object - (:print-object (lambda (x s) - (print-unreadable-object (x s :type t) - (prin1 (class-info-name x))))) - (:copier nil)) + (:constructor make-class-info (name)) + #-no-ansi-print-object + (:print-object (lambda (x s) + (print-unreadable-object (x s :type t) + (prin1 (class-info-name x))))) + (:copier nil)) ;; name of this class (name nil :type keyword :read-only t) ;; list of Type-Info structures for each type in this class @@ -143,18 +143,18 @@ #-sb-xc ; as per KLUDGE note above (eval-when (:compile-toplevel :execute) (setf *info-types* - (make-array (ash 1 type-number-bits) :initial-element nil))) + (make-array (ash 1 type-number-bits) :initial-element nil))) (defstruct (type-info - #-no-ansi-print-object - (:print-object (lambda (x s) - (print-unreadable-object (x s) - (format s - "~S ~S, Number = ~W" - (class-info-name (type-info-class x)) - (type-info-name x) - (type-info-number x))))) - (:copier nil)) + #-no-ansi-print-object + (:print-object (lambda (x s) + (print-unreadable-object (x s) + (format s + "~S ~S, Number = ~W" + (class-info-name (type-info-class x)) + (type-info-name x) + (type-info-number x))))) + (:copier nil)) ;; the name of this type (name (missing-arg) :type keyword) ;; this type's class @@ -162,7 +162,7 @@ ;; a number that uniquely identifies this type (and implicitly its class) (number (missing-arg) :type type-number) ;; a type specifier which info of this type must satisfy - (type nil :type t) + (type nil :type t) ;; a function called when there is no information of this type (default (lambda () (error "type not defined yet")) :type function) ;; called by (SETF INFO) before calling SET-INFO-VALUE @@ -198,7 +198,7 @@ #+sb-xc (/nohexstr class) (prog1 (or (gethash class *info-classes*) - (error "~S is not a defined info class." class)) + (error "~S is not a defined info class." class)) #+sb-xc (/noshow0 "returning from CLASS-INFO-OR-LOSE"))) (declaim (ftype (function (keyword keyword) type-info) type-info-or-lose)) (defun type-info-or-lose (class type) @@ -207,7 +207,7 @@ #+sb-xc (/nohexstr type) (prog1 (or (find-type-info type (class-info-or-lose class)) - (error "~S is not a defined info type." type)) + (error "~S is not a defined info type." type)) #+sb-xc (/noshow0 "returning from TYPE-INFO-OR-LOSE"))) ) ; EVAL-WHEN @@ -241,7 +241,7 @@ ;; those data structures.) (eval-when (:compile-toplevel :execute) (unless (gethash ,class *info-classes*) - (setf (gethash ,class *info-classes*) (make-class-info ,class)))) + (setf (gethash ,class *info-classes*) (make-class-info ,class)))) ,class)) ;;; Find a type number not already in use by looking for a null entry @@ -269,7 +269,7 @@ ;;; hasn't been set, and TYPE-SPEC is a type specifier which values of ;;; the type must satisfy. The default expression is evaluated each ;;; time the information is needed, with NAME bound to the name for -;;; which the information is being looked up. +;;; which the information is being looked up. ;;; ;;; The main thing we do is determine the type's number. We need to do ;;; this at macroexpansion time, since both the COMPILE and LOAD time @@ -277,10 +277,10 @@ (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro define-info-type (&key (class (missing-arg)) - (type (missing-arg)) - (type-spec (missing-arg)) - (validate-function) - default) + (type (missing-arg)) + (type-spec (missing-arg)) + (validate-function) + default) (declare (type keyword class type)) `(progn (eval-when (:compile-toplevel :execute) @@ -290,15 +290,15 @@ ;; looks at the compile time state and generates code to ;; replicate it at cold load time. (let* ((class-info (class-info-or-lose ',class)) - (old-type-info (find-type-info ',type class-info))) - (unless old-type-info - (let* ((new-type-number (find-unused-type-number)) - (new-type-info - (make-type-info :name ',type - :class class-info - :number new-type-number))) - (setf (aref *info-types* new-type-number) new-type-info) - (push new-type-info (class-info-types class-info))))) + (old-type-info (find-type-info ',type class-info))) + (unless old-type-info + (let* ((new-type-number (find-unused-type-number)) + (new-type-info + (make-type-info :name ',type + :class class-info + :number new-type-number))) + (setf (aref *info-types* new-type-number) new-type-info) + (push new-type-info (class-info-types class-info))))) ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set ;; at cold load time. (They can't very well be set at ;; cross-compile time, since they differ between the @@ -307,22 +307,22 @@ ;; values differ in the use of SB!XC symbols instead of CL ;; symbols.) (push `(let ((type-info (type-info-or-lose ,',class ,',type))) - (setf (type-info-validate-function type-info) - ,',validate-function) - (setf (type-info-default type-info) - ;; FIXME: This code is sort of nasty. It would - ;; be cleaner if DEFAULT accepted a real - ;; function, instead of accepting a statement - ;; which will be turned into a lambda assuming - ;; that the argument name is NAME. It might - ;; even be more microefficient, too, since many - ;; DEFAULTs could be implemented as (CONSTANTLY - ;; NIL) instead of full-blown (LAMBDA (X) NIL). - (lambda (name) - (declare (ignorable name)) - ,',default)) - (setf (type-info-type type-info) ',',type-spec)) - *!reversed-type-info-init-forms*)) + (setf (type-info-validate-function type-info) + ,',validate-function) + (setf (type-info-default type-info) + ;; FIXME: This code is sort of nasty. It would + ;; be cleaner if DEFAULT accepted a real + ;; function, instead of accepting a statement + ;; which will be turned into a lambda assuming + ;; that the argument name is NAME. It might + ;; even be more microefficient, too, since many + ;; DEFAULTs could be implemented as (CONSTANTLY + ;; NIL) instead of full-blown (LAMBDA (X) NIL). + (lambda (name) + (declare (ignorable name)) + ,',default)) + (setf (type-info-type type-info) ',',type-spec)) + *!reversed-type-info-init-forms*)) ',type)) ) ; EVAL-WHEN @@ -335,7 +335,7 @@ ;;; didn't win, we would try to use the type system before it was ;;; properly initialized. (defstruct (info-env (:constructor nil) - (:copier nil)) + (:copier nil)) ;; some string describing what is in this environment, for ;; printing/debugging purposes only (name (missing-arg) :type string)) @@ -347,8 +347,8 @@ ;;; FIXME: used only in this file, needn't be in runtime (defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym)) - (type-number (gensym)) (value (gensym)) known-volatile) - &body body) + (type-number (gensym)) (value (gensym)) known-volatile) + &body body) #!+sb-doc "DO-INFO (Env &Key Name Class Type Value) Form* Iterate over all the values stored in the Info-Env Env. Name is bound to @@ -356,75 +356,75 @@ (represented as keywords), and Value is bound to the entry's value." (once-only ((n-env env)) (if known-volatile - (do-volatile-info name class type type-number value n-env body) - `(if (typep ,n-env 'volatile-info-env) - ,(do-volatile-info name class type type-number value n-env body) - ,(do-compact-info name class type type-number value - n-env body))))) + (do-volatile-info name class type type-number value n-env body) + `(if (typep ,n-env 'volatile-info-env) + ,(do-volatile-info name class type type-number value n-env body) + ,(do-compact-info name class type type-number value + n-env body))))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; Return code to iterate over a compact info environment. (defun do-compact-info (name-var class-var type-var type-number-var value-var - n-env body) + n-env body) (let ((n-index (gensym)) - (n-type (gensym)) - (punt (gensym))) + (n-type (gensym)) + (punt (gensym))) (once-only ((n-table `(compact-info-env-table ,n-env)) - (n-entries-index `(compact-info-env-index ,n-env)) - (n-entries `(compact-info-env-entries ,n-env)) - (n-entries-info `(compact-info-env-entries-info ,n-env)) - (n-info-types '*info-types*)) + (n-entries-index `(compact-info-env-index ,n-env)) + (n-entries `(compact-info-env-entries ,n-env)) + (n-entries-info `(compact-info-env-entries-info ,n-env)) + (n-info-types '*info-types*)) `(dotimes (,n-index (length ,n-table)) - (declare (type index ,n-index)) - (block ,punt - (let ((,name-var (svref ,n-table ,n-index))) - (unless (eql ,name-var 0) - (do-anonymous ((,n-type (aref ,n-entries-index ,n-index) - (1+ ,n-type))) - (nil) - (declare (type index ,n-type)) - ,(once-only ((n-info `(aref ,n-entries-info ,n-type))) - `(let ((,type-number-var - (logand ,n-info compact-info-entry-type-mask))) - ,(once-only ((n-type-info - `(svref ,n-info-types - ,type-number-var))) - `(let ((,type-var (type-info-name ,n-type-info)) - (,class-var (class-info-name - (type-info-class ,n-type-info))) - (,value-var (svref ,n-entries ,n-type))) - (declare (ignorable ,type-var ,class-var - ,value-var)) - ,@body - (unless (zerop (logand ,n-info - compact-info-entry-last)) - (return-from ,punt)))))))))))))) + (declare (type index ,n-index)) + (block ,punt + (let ((,name-var (svref ,n-table ,n-index))) + (unless (eql ,name-var 0) + (do-anonymous ((,n-type (aref ,n-entries-index ,n-index) + (1+ ,n-type))) + (nil) + (declare (type index ,n-type)) + ,(once-only ((n-info `(aref ,n-entries-info ,n-type))) + `(let ((,type-number-var + (logand ,n-info compact-info-entry-type-mask))) + ,(once-only ((n-type-info + `(svref ,n-info-types + ,type-number-var))) + `(let ((,type-var (type-info-name ,n-type-info)) + (,class-var (class-info-name + (type-info-class ,n-type-info))) + (,value-var (svref ,n-entries ,n-type))) + (declare (ignorable ,type-var ,class-var + ,value-var)) + ,@body + (unless (zerop (logand ,n-info + compact-info-entry-last)) + (return-from ,punt)))))))))))))) ;;; Return code to iterate over a volatile info environment. (defun do-volatile-info (name-var class-var type-var type-number-var value-var - n-env body) + n-env body) (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym))) (once-only ((n-table `(volatile-info-env-table ,n-env)) - (n-info-types '*info-types*)) + (n-info-types '*info-types*)) `(dotimes (,n-index (length ,n-table)) - (declare (type index ,n-index)) - (do-anonymous ((,n-names (svref ,n-table ,n-index) - (cdr ,n-names))) - ((null ,n-names)) - (let ((,name-var (caar ,n-names))) - (declare (ignorable ,name-var)) - (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types))) - ((null ,n-types)) - (let ((,type-number-var (caar ,n-types))) - ,(once-only ((n-type `(svref ,n-info-types - ,type-number-var))) - `(let ((,type-var (type-info-name ,n-type)) - (,class-var (class-info-name - (type-info-class ,n-type))) - (,value-var (cdar ,n-types))) - (declare (ignorable ,type-var ,class-var ,value-var)) - ,@body)))))))))) + (declare (type index ,n-index)) + (do-anonymous ((,n-names (svref ,n-table ,n-index) + (cdr ,n-names))) + ((null ,n-names)) + (let ((,name-var (caar ,n-names))) + (declare (ignorable ,name-var)) + (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types))) + ((null ,n-types)) + (let ((,type-number-var (caar ,n-types))) + ,(once-only ((n-type `(svref ,n-info-types + ,type-number-var))) + `(let ((,type-var (type-info-name ,n-type)) + (,class-var (class-info-name + (type-info-class ,n-type))) + (,value-var (cdar ,n-types))) + (declare (ignorable ,type-var ,class-var ,value-var)) + ,@body)))))))))) ) ; EVAL-WHEN @@ -446,8 +446,8 @@ (defun info-cache-hash (name type) (logand (the fixnum - (logxor (globaldb-sxhashoid name) - (ash (the fixnum type) 7))) + (logxor (globaldb-sxhashoid name) + (ash (the fixnum type) 7))) #x3FF)) (!cold-init-forms @@ -482,14 +482,14 @@ ;;;; compact info environments ;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV. -;;; +;;; ;;; "Why (U-B 28)?", you might wonder. Originally this was (U-B 16), -;;; presumably to ensure that the arrays of :ELEMENT-TYPE +;;; presumably to ensure that the arrays of :ELEMENT-TYPE ;;; COMPACT-INFO-ENTRIES-INDEX could use a more space-efficient representation. ;;; It turns out that a environment of of only 65536 entries is insufficient in ;;; the modern world (see message from Cyrus Harmon to sbcl-devel, "Subject: ;;; purify failure when compact-info-env-entries-bits is too small"). Using -;;; (U-B 28) instead of (U-B 29) is to avoid the need for bignum overflow +;;; (U-B 28) instead of (U-B 29) is to avoid the need for bignum overflow ;;; checks, a probably pointless micro-optimization. Hardcoding the amount of ;;; bits instead of deriving it from SB!VM::N-WORD-BITS is done to allow ;;; use of a more efficient array representation on 64-bit platforms. @@ -505,8 +505,8 @@ ;;; indirect through a parallel vector to find the index in the ;;; ENTRIES at which the entries for a given name starts. (defstruct (compact-info-env (:include info-env) - #-sb-xc-host (:pure :substructure) - (:copier nil)) + #-sb-xc-host (:pure :substructure) + (:copier nil)) ;; If this value is EQ to the name we want to look up, then the ;; cache hit function can be called instead of the lookup function. (cache-name 0) @@ -539,48 +539,48 @@ (defun compact-info-cache-hit (env number) (declare (type compact-info-env env) (type type-number number)) (let ((entries-info (compact-info-env-entries-info env)) - (index (compact-info-env-cache-index env))) + (index (compact-info-env-cache-index env))) (if index - (do ((index index (1+ index))) - (nil) - (declare (type index index)) - (let ((info (aref entries-info index))) - (when (= (logand info compact-info-entry-type-mask) number) - (return (values (svref (compact-info-env-entries env) index) - t))) - (unless (zerop (logand compact-info-entry-last info)) - (return (values nil nil))))) - (values nil nil)))) + (do ((index index (1+ index))) + (nil) + (declare (type index index)) + (let ((info (aref entries-info index))) + (when (= (logand info compact-info-entry-type-mask) number) + (return (values (svref (compact-info-env-entries env) index) + t))) + (unless (zerop (logand compact-info-entry-last info)) + (return (values nil nil))))) + (values nil nil)))) ;;; Encache NAME in the compact environment ENV. HASH is the ;;; GLOBALDB-SXHASHOID of NAME. (defun compact-info-lookup (env name hash) (declare (type compact-info-env env) - (type (integer 0 #.sb!xc:most-positive-fixnum) hash)) + (type (integer 0 #.sb!xc:most-positive-fixnum) hash)) (let* ((table (compact-info-env-table env)) - (len (length table)) - (len-2 (- len 2)) - (hash2 (- len-2 (rem hash len-2)))) + (len (length table)) + (len-2 (- len 2)) + (hash2 (- len-2 (rem hash len-2)))) (declare (type index len-2 hash2)) (macrolet ((lookup (test) - `(do ((probe (rem hash len) - (let ((new (+ probe hash2))) - (declare (type index new)) - ;; same as (MOD NEW LEN), but faster. - (if (>= new len) - (the index (- new len)) - new)))) - (nil) - (let ((entry (svref table probe))) - (when (eql entry 0) - (return nil)) - (when (,test entry name) - (return (aref (compact-info-env-index env) - probe))))))) + `(do ((probe (rem hash len) + (let ((new (+ probe hash2))) + (declare (type index new)) + ;; same as (MOD NEW LEN), but faster. + (if (>= new len) + (the index (- new len)) + new)))) + (nil) + (let ((entry (svref table probe))) + (when (eql entry 0) + (return nil)) + (when (,test entry name) + (return (aref (compact-info-env-index env) + probe))))))) (setf (compact-info-env-cache-index env) - (if (symbolp name) - (lookup eq) - (lookup equal))) + (if (symbolp name) + (lookup eq) + (lookup equal))) (setf (compact-info-env-cache-name env) name))) (values)) @@ -593,8 +593,8 @@ ;;; information as ENV. (defun compact-info-environment (env &key (name (info-env-name env))) (let ((name-count 0) - (prev-name 0) - (entry-count 0)) + (prev-name 0) + (entry-count 0)) (/show0 "before COLLECT in COMPACT-INFO-ENVIRONMENT") ;; Iterate over the environment once to find out how many names @@ -606,93 +606,93 @@ (/show0 "at head of COLLECT in COMPACT-INFO-ENVIRONMENT") (let ((types ())) - (do-info (env :name name :type-number num :value value) - (/noshow0 "at head of DO-INFO in COMPACT-INFO-ENVIRONMENT") - (unless (eq name prev-name) + (do-info (env :name name :type-number num :value value) + (/noshow0 "at head of DO-INFO in COMPACT-INFO-ENVIRONMENT") + (unless (eq name prev-name) (/noshow0 "not (EQ NAME PREV-NAME) case") - (incf name-count) - (unless (eql prev-name 0) - (names (cons prev-name types))) - (setq prev-name name) - (setq types ())) - (incf entry-count) - (push (cons num value) types)) - (unless (eql prev-name 0) + (incf name-count) + (unless (eql prev-name 0) + (names (cons prev-name types))) + (setq prev-name name) + (setq types ())) + (incf entry-count) + (push (cons num value) types)) + (unless (eql prev-name 0) (/show0 "not (EQL PREV-NAME 0) case") - (names (cons prev-name types)))) + (names (cons prev-name types)))) ;; Now that we know how big the environment is, we can build ;; a table to represent it. - ;; + ;; ;; When building the table, we sort the entries by pointer ;; comparison in an attempt to preserve any VM locality present ;; in the original load order, rather than randomizing with the ;; original hash function. (/show0 "about to make/sort vectors in COMPACT-INFO-ENVIRONMENT") (let* ((table-size (primify - (+ (truncate (* name-count 100) - compact-info-environment-density) - 3))) - (table (make-array table-size :initial-element 0)) - (index (make-array table-size - :element-type 'compact-info-entries-index)) - (entries (make-array entry-count)) - (entries-info (make-array entry-count - :element-type 'compact-info-entry)) - (sorted (sort (names) - #+sb-xc-host #'< - ;; (This MAKE-FIXNUM hack implements - ;; pointer comparison, as explained above.) - #-sb-xc-host (lambda (x y) - (< (%primitive make-fixnum x) - (%primitive make-fixnum y)))))) - (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT") - (let ((entries-idx 0)) - (dolist (types sorted) - (let* ((name (first types)) - (hash (globaldb-sxhashoid name)) - (len-2 (- table-size 2)) - (hash2 (- len-2 (rem hash len-2)))) - (do ((probe (rem hash table-size) - (rem (+ probe hash2) table-size))) - (nil) - (let ((entry (svref table probe))) - (when (eql entry 0) - (setf (svref table probe) name) - (setf (aref index probe) entries-idx) - (return)) - (aver (not (equal entry name)))))) - - (unless (zerop entries-idx) - (setf (aref entries-info (1- entries-idx)) - (logior (aref entries-info (1- entries-idx)) - compact-info-entry-last))) - - (loop for (num . value) in (rest types) do - (setf (aref entries-info entries-idx) num) - (setf (aref entries entries-idx) value) - (incf entries-idx))) - (/show0 "done w/ DOLIST (TYPES SORTED) in COMPACT-INFO-ENVIRONMENT") - - (unless (zerop entry-count) - (/show0 "nonZEROP ENTRY-COUNT") - (setf (aref entries-info (1- entry-count)) - (logior (aref entries-info (1- entry-count)) - compact-info-entry-last))) - - (/show0 "falling through to MAKE-COMPACT-INFO-ENV") - (make-compact-info-env :name name - :table table - :index index - :entries entries - :entries-info entries-info)))))) + (+ (truncate (* name-count 100) + compact-info-environment-density) + 3))) + (table (make-array table-size :initial-element 0)) + (index (make-array table-size + :element-type 'compact-info-entries-index)) + (entries (make-array entry-count)) + (entries-info (make-array entry-count + :element-type 'compact-info-entry)) + (sorted (sort (names) + #+sb-xc-host #'< + ;; (This MAKE-FIXNUM hack implements + ;; pointer comparison, as explained above.) + #-sb-xc-host (lambda (x y) + (< (%primitive make-fixnum x) + (%primitive make-fixnum y)))))) + (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT") + (let ((entries-idx 0)) + (dolist (types sorted) + (let* ((name (first types)) + (hash (globaldb-sxhashoid name)) + (len-2 (- table-size 2)) + (hash2 (- len-2 (rem hash len-2)))) + (do ((probe (rem hash table-size) + (rem (+ probe hash2) table-size))) + (nil) + (let ((entry (svref table probe))) + (when (eql entry 0) + (setf (svref table probe) name) + (setf (aref index probe) entries-idx) + (return)) + (aver (not (equal entry name)))))) + + (unless (zerop entries-idx) + (setf (aref entries-info (1- entries-idx)) + (logior (aref entries-info (1- entries-idx)) + compact-info-entry-last))) + + (loop for (num . value) in (rest types) do + (setf (aref entries-info entries-idx) num) + (setf (aref entries entries-idx) value) + (incf entries-idx))) + (/show0 "done w/ DOLIST (TYPES SORTED) in COMPACT-INFO-ENVIRONMENT") + + (unless (zerop entry-count) + (/show0 "nonZEROP ENTRY-COUNT") + (setf (aref entries-info (1- entry-count)) + (logior (aref entries-info (1- entry-count)) + compact-info-entry-last))) + + (/show0 "falling through to MAKE-COMPACT-INFO-ENV") + (make-compact-info-env :name name + :table table + :index index + :entries entries + :entries-info entries-info)))))) ;;;; volatile environments ;;; This is a closed hashtable, with the bucket being computed by ;;; taking the GLOBALDB-SXHASHOID of the NAME modulo the table size. (defstruct (volatile-info-env (:include info-env) - (:copier nil)) + (:copier nil)) ;; If this value is EQ to the name we want to look up, then the ;; cache hit function can be called instead of the lookup function. (cache-name 0) @@ -719,16 +719,16 @@ ;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment. (defun volatile-info-lookup (env name hash) (declare (type volatile-info-env env) - (type (integer 0 #.sb!xc:most-positive-fixnum) hash)) + (type (integer 0 #.sb!xc:most-positive-fixnum) hash)) (let ((table (volatile-info-env-table env))) (macrolet ((lookup (test) - `(dolist (entry (svref table (mod hash (length table))) ()) - (when (,test (car entry) name) - (return (cdr entry)))))) + `(dolist (entry (svref table (mod hash (length table))) ()) + (when (,test (car entry) name) + (return (cdr entry)))))) (setf (volatile-info-env-cache-types env) - (if (symbolp name) - (lookup eq) - (lookup equal))) + (if (symbolp name) + (lookup eq) + (lookup equal))) (setf (volatile-info-env-cache-name env) name))) (values)) @@ -740,13 +740,13 @@ #-sb-xc-host sb!xc:defmacro with-info-bucket ((table-var index-var name env) &body body) (once-only ((n-name name) - (n-env env)) + (n-env env)) `(progn - (setf (volatile-info-env-cache-name ,n-env) 0) - (let* ((,table-var (volatile-info-env-table ,n-env)) - (,index-var (mod (globaldb-sxhashoid ,n-name) - (length ,table-var)))) - ,@body))))) + (setf (volatile-info-env-cache-name ,n-env) 0) + (let* ((,table-var (volatile-info-env-table ,n-env)) + (,index-var (mod (globaldb-sxhashoid ,n-name) + (length ,table-var)))) + ,@body))))) ;;; Get the info environment that we use for write/modification operations. ;;; This is always the first environment in the list, and must be a @@ -772,9 +772,9 @@ ;;; We return the new value so that this can be conveniently used in a ;;; SETF function. (defun set-info-value (name0 type new-value - &optional (env (get-write-info-env))) + &optional (env (get-write-info-env))) (declare (type type-number type) (type volatile-info-env env) - (inline assoc)) + (inline assoc)) (let ((name (uncross name0))) (when (eql name 0) (error "0 is not a legal INFO name.")) @@ -783,29 +783,29 @@ (info-cache-enter name type nil :empty) (with-info-bucket (table index name env) (let ((types (if (symbolp name) - (assoc name (svref table index) :test #'eq) - (assoc name (svref table index) :test #'equal)))) - (cond - (types - (let ((value (assoc type (cdr types)))) - (if value - (setf (cdr value) new-value) - (push (cons type new-value) (cdr types))))) - (t - (push (cons name (list (cons type new-value))) - (svref table index)) - - (let ((count (incf (volatile-info-env-count env)))) - (when (>= count (volatile-info-env-threshold env)) - (let ((new (make-info-environment :size (* count 2)))) - (do-info (env :name entry-name :type-number entry-num - :value entry-val :known-volatile t) - (set-info-value entry-name entry-num entry-val new)) - (fill (volatile-info-env-table env) nil) - (setf (volatile-info-env-table env) - (volatile-info-env-table new)) - (setf (volatile-info-env-threshold env) - (volatile-info-env-threshold new))))))))) + (assoc name (svref table index) :test #'eq) + (assoc name (svref table index) :test #'equal)))) + (cond + (types + (let ((value (assoc type (cdr types)))) + (if value + (setf (cdr value) new-value) + (push (cons type new-value) (cdr types))))) + (t + (push (cons name (list (cons type new-value))) + (svref table index)) + + (let ((count (incf (volatile-info-env-count env)))) + (when (>= count (volatile-info-env-threshold env)) + (let ((new (make-info-environment :size (* count 2)))) + (do-info (env :name entry-name :type-number entry-num + :value entry-val :known-volatile t) + (set-info-value entry-name entry-num entry-val new)) + (fill (volatile-info-env-table env) nil) + (setf (volatile-info-env-table env) + (volatile-info-env-table new)) + (setf (volatile-info-env-threshold env) + (volatile-info-env-threshold new))))))))) new-value)) ;;; FIXME: It should be possible to eliminate the hairy compiler macros below @@ -826,8 +826,8 @@ ;; least none in any inner loops. (let ((info (type-info-or-lose class type))) (if env-list-p - (get-info-value name (type-info-number info) env-list) - (get-info-value name (type-info-number info))))) + (get-info-value name (type-info-number info) env-list) + (get-info-value name (type-info-number info))))) #!-sb-fluid (define-compiler-macro info (&whole whole class type name &optional (env-list nil env-list-p)) @@ -835,31 +835,31 @@ ;; and we can implement it much more efficiently than the general case. (if (and (constantp class) (constantp type)) (let ((info (type-info-or-lose class type))) - (with-unique-names (value foundp) - `(multiple-value-bind (,value ,foundp) - (get-info-value ,name - ,(type-info-number info) - ,@(when env-list-p `(,env-list))) - (declare (type ,(type-info-type info) ,value)) - (values ,value ,foundp)))) + (with-unique-names (value foundp) + `(multiple-value-bind (,value ,foundp) + (get-info-value ,name + ,(type-info-number info) + ,@(when env-list-p `(,env-list))) + (declare (type ,(type-info-type info) ,value)) + (values ,value ,foundp)))) whole)) (defun (setf info) (new-value - class - type - name - &optional (env-list nil env-list-p)) + class + type + name + &optional (env-list nil env-list-p)) (let* ((info (type-info-or-lose class type)) - (tin (type-info-number info))) + (tin (type-info-number info))) (when (type-info-validate-function info) (funcall (type-info-validate-function info) name new-value)) (if env-list-p - (set-info-value name - tin - new-value - (get-write-info-env env-list)) - (set-info-value name - tin - new-value))) + (set-info-value name + tin + new-value + (get-write-info-env env-list)) + (set-info-value name + tin + new-value))) new-value) ;;; FIXME: We'd like to do this, but Python doesn't support ;;; compiler macros and it's hard to change it so that it does. @@ -872,25 +872,25 @@ #!-sb-fluid (progn (define-compiler-macro (setf info) (&whole whole - new-value - class - type - name - &optional (env-list nil env-list-p)) + new-value + class + type + name + &optional (env-list nil env-list-p)) ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we ;; can resolve it much more efficiently than the general case. (if (and (constantp class) (constantp type)) - (let* ((info (type-info-or-lose class type)) - (tin (type-info-number info))) - (if env-list-p - `(set-info-value ,name - ,tin - ,new-value - (get-write-info-env ,env-list)) - `(set-info-value ,name - ,tin - ,new-value))) - whole))) + (let* ((info (type-info-or-lose class type)) + (tin (type-info-number info))) + (if env-list-p + `(set-info-value ,name + ,tin + ,new-value + (get-write-info-env ,env-list)) + `(set-info-value ,name + ,tin + ,new-value))) + whole))) |# ;;; the maximum density of the hashtable in a volatile env (in @@ -904,10 +904,10 @@ (defun make-info-environment (&key (size 42) (name "Unknown")) (declare (type (integer 1) size)) (let ((table-size (primify (truncate (* size 100) - volatile-info-environment-density)))) + volatile-info-environment-density)))) (make-volatile-info-env :name name - :table (make-array table-size :initial-element nil) - :threshold size))) + :table (make-array table-size :initial-element nil) + :threshold size))) ;;; Clear the information of the specified TYPE and CLASS for NAME in ;;; the current environment, allowing any inherited info to become @@ -930,10 +930,10 @@ (with-info-bucket (table index name (get-write-info-env)) (let ((types (assoc name (svref table index) :test #'equal))) (when (and types - (assoc type (cdr types))) - (setf (cdr types) - (delete type (cdr types) :key #'car)) - t)))) + (assoc type (cdr types))) + (setf (cdr types) + (delete type (cdr types) :key #'car)) + t)))) ;;;; *INFO-ENVIRONMENT* @@ -943,7 +943,7 @@ (declaim (type list *info-environment*)) (!cold-init-forms (setq *info-environment* - (list (make-info-environment :name "initial global"))) + (list (make-info-environment :name "initial global"))) (/show0 "done setting *INFO-ENVIRONMENT*")) ;;; FIXME: should perhaps be *INFO-ENV-LIST*. And rename ;;; all FOO-INFO-ENVIRONMENT-BAR stuff to FOO-INFO-ENV-BAR. @@ -970,43 +970,43 @@ (aver (aref *info-types* type)) (let ((name (uncross name0))) (flet ((lookup-ignoring-global-cache (env-list) - (let ((hash nil)) - (dolist (env env-list - (multiple-value-bind (val winp) - (funcall (type-info-default - (svref *info-types* type)) - name) - (values val winp))) - (macrolet ((frob (lookup cache slot) - `(progn - (unless (eq name (,slot env)) - (unless hash - (setq hash (globaldb-sxhashoid name))) - (setf (,slot env) 0) - (,lookup env name hash)) - (multiple-value-bind (value winp) - (,cache env type) - (when winp (return (values value t))))))) - (etypecase env - (volatile-info-env (frob - volatile-info-lookup - volatile-info-cache-hit - volatile-info-env-cache-name)) - (compact-info-env (frob - compact-info-lookup - compact-info-cache-hit - compact-info-env-cache-name)))))))) + (let ((hash nil)) + (dolist (env env-list + (multiple-value-bind (val winp) + (funcall (type-info-default + (svref *info-types* type)) + name) + (values val winp))) + (macrolet ((frob (lookup cache slot) + `(progn + (unless (eq name (,slot env)) + (unless hash + (setq hash (globaldb-sxhashoid name))) + (setf (,slot env) 0) + (,lookup env name hash)) + (multiple-value-bind (value winp) + (,cache env type) + (when winp (return (values value t))))))) + (etypecase env + (volatile-info-env (frob + volatile-info-lookup + volatile-info-cache-hit + volatile-info-env-cache-name)) + (compact-info-env (frob + compact-info-lookup + compact-info-cache-hit + compact-info-env-cache-name)))))))) (cond (env-list-p - (lookup-ignoring-global-cache env-list)) - (t - (clear-invalid-info-cache) - (multiple-value-bind (val winp) (info-cache-lookup name type) - (if (eq winp :empty) - (multiple-value-bind (val winp) - (lookup-ignoring-global-cache *info-environment*) - (info-cache-enter name type val winp) - (values val winp)) - (values val winp)))))))) + (lookup-ignoring-global-cache env-list)) + (t + (clear-invalid-info-cache) + (multiple-value-bind (val winp) (info-cache-lookup name type) + (if (eq winp :empty) + (multiple-value-bind (val winp) + (lookup-ignoring-global-cache *info-environment*) + (info-cache-enter name type val winp) + (values val winp)) + (values val winp)))))))) ;;;; definitions for function information @@ -1039,8 +1039,8 @@ :default #+sb-xc-host (specifier-type 'function) #-sb-xc-host (if (fboundp name) - (extract-fun-type (fdefinition name)) - (specifier-type 'function))) + (extract-fun-type (fdefinition name)) + (specifier-type 'function))) ;;; the ASSUMED-TYPE for this function, if we have to infer the type ;;; due to not having a declaration or definition @@ -1078,7 +1078,7 @@ ;;; To inline a function, we want a lambda expression, e.g. ;;; '(LAMBDA (X) (+ X 1)). That can be encoded here in one of two ;;; ways. -;;; * The value in INFO can be the lambda expression itself, e.g. +;;; * The value in INFO can be the lambda expression itself, e.g. ;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'FOO) ;;; '(LAMBDA (X) (+ X 1))) ;;; This is the ordinary way, the natural way of representing e.g. @@ -1164,8 +1164,8 @@ :type :kind :type-spec (member :special :constant :macro :global :alien) :default (if (symbol-self-evaluating-p name) - :constant - :global)) + :constant + :global)) ;;; the declared type for this variable (define-info-type @@ -1194,8 +1194,8 @@ ;; as a constant?") should check (EQL (INFO :VARIABLE :KIND ..) :CONSTANT) ;; instead. :default (if (symbol-self-evaluating-p name) - name - (bug "constant lookup of nonconstant ~S" name))) + name + (bug "constant lookup of nonconstant ~S" name))) ;;; the macro-expansion for symbol-macros (define-info-type @@ -1226,14 +1226,14 @@ :class :type :type :kind :type-spec (member :primitive :defined :instance - :forthcoming-defclass-type nil) + :forthcoming-defclass-type nil) :default nil :validate-function (lambda (name new-value) - (declare (ignore new-value) - (notinline info)) - (when (info :declaration :recognized name) - (error 'declaration-type-conflict-error - :format-arguments (list name))))) + (declare (ignore new-value) + (notinline info)) + (when (info :declaration :recognized name) + (error 'declaration-type-conflict-error + :format-arguments (list name))))) ;;; the expander function for a defined type (define-info-type @@ -1283,7 +1283,7 @@ :type :compiler-layout :type-spec (or layout null) :default (let ((class (find-classoid name nil))) - (when class (classoid-layout class)))) + (when class (classoid-layout class)))) (define-info-class :typed-structure) (define-info-type @@ -1292,7 +1292,7 @@ :type-spec t :default nil) (define-info-type - :class :typed-structure + :class :typed-structure :type :documentation :type-spec (or string null) :default nil) @@ -1303,11 +1303,11 @@ :type :recognized :type-spec boolean :validate-function (lambda (name new-value) - (declare (ignore new-value) - (notinline info)) - (when (info :type :kind name) - (error 'declaration-type-conflict-error - :format-arguments (list name))))) + (declare (ignore new-value) + (notinline info)) + (when (info :type :kind name) + (error 'declaration-type-conflict-error + :format-arguments (list name))))) (define-info-class :alien-type) (define-info-type @@ -1378,48 +1378,48 @@ (!cold-init-forms (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE") (setf *info-classes* - (make-hash-table :size #.(hash-table-size *info-classes*))) + (make-hash-table :size #.(hash-table-size *info-classes*))) (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init") (dolist (class-info-name '#.(let ((result nil)) - (maphash (lambda (key value) - (declare (ignore value)) - (push key result)) - *info-classes*) - result)) + (maphash (lambda (key value) + (declare (ignore value)) + (push key result)) + *info-classes*) + result)) (let ((class-info (make-class-info class-info-name))) (setf (gethash class-info-name *info-classes*) - class-info))) + class-info))) (/show0 "done with *INFO-CLASSES* initialization") (/show0 "beginning *INFO-TYPES* initialization") (setf *info-types* - (map 'vector - (lambda (x) - (/show0 "in LAMBDA (X), X=..") - (/hexstr x) - (when x - (let* ((class-info (class-info-or-lose (second x))) - (type-info (make-type-info :name (first x) - :class class-info - :number (third x) - :type (fourth x)))) - (/show0 "got CLASS-INFO in LAMBDA (X)") - (push type-info (class-info-types class-info)) - type-info))) - '#.(map 'list - (lambda (info-type) - (when info-type - (list (type-info-name info-type) - (class-info-name (type-info-class info-type)) - (type-info-number info-type) - (type-info-type info-type)))) - *info-types*))) + (map 'vector + (lambda (x) + (/show0 "in LAMBDA (X), X=..") + (/hexstr x) + (when x + (let* ((class-info (class-info-or-lose (second x))) + (type-info (make-type-info :name (first x) + :class class-info + :number (third x) + :type (fourth x)))) + (/show0 "got CLASS-INFO in LAMBDA (X)") + (push type-info (class-info-types class-info)) + type-info))) + '#.(map 'list + (lambda (info-type) + (when info-type + (list (type-info-name info-type) + (class-info-name (type-info-class info-type)) + (type-info-number info-type) + (type-info-type info-type)))) + *info-types*))) (/show0 "done with *INFO-TYPES* initialization")) ;;; At cold load time, after the INFO-TYPE objects have been created, ;;; we can set their DEFAULT and TYPE slots. (macrolet ((frob () - `(!cold-init-forms - ,@(reverse *!reversed-type-info-init-forms*)))) + `(!cold-init-forms + ,@(reverse *!reversed-type-info-init-forms*)))) (frob)) ;;;; a hack for detecting diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index c1fb1c7..1a22dd0 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -25,7 +25,7 @@ (assign-ir2-nlx-info fun) (assign-lambda-var-tns fun nil) (dolist (let (lambda-lets fun)) - (assign-lambda-var-tns let t)))) + (assign-lambda-var-tns let t)))) (values)) @@ -41,17 +41,17 @@ (dolist (var (lambda-vars fun)) (when (leaf-refs var) (let* ((type (if (lambda-var-indirect var) - *backend-t-primitive-type* - (primitive-type (leaf-type var)))) - (temp (make-normal-tn type)) - (node (lambda-bind fun)) - (res (if (or (and let-p (policy node (< debug 3))) - (policy node (zerop debug)) - (policy node (= speed 3))) - temp - (physenv-debug-live-tn temp (lambda-physenv fun))))) - (setf (tn-leaf res) var) - (setf (leaf-info var) res)))) + *backend-t-primitive-type* + (primitive-type (leaf-type var)))) + (temp (make-normal-tn type)) + (node (lambda-bind fun)) + (res (if (or (and let-p (policy node (< debug 3))) + (policy node (zerop debug)) + (policy node (= speed 3))) + temp + (physenv-debug-live-tn temp (lambda-physenv fun))))) + (setf (tn-leaf res) var) + (setf (leaf-info var) res)))) (values)) ;;; Give CLAMBDA an IR2-PHYSENV structure. (And in order to @@ -60,28 +60,28 @@ (defun assign-ir2-physenv (clambda) (declare (type clambda clambda)) (let ((lambda-physenv (lambda-physenv clambda)) - (reversed-ir2-physenv-alist nil)) + (reversed-ir2-physenv-alist nil)) ;; FIXME: should be MAPCAR, not DOLIST (dolist (thing (physenv-closure lambda-physenv)) (let ((ptype (etypecase thing - (lambda-var - (if (lambda-var-indirect thing) - *backend-t-primitive-type* - (primitive-type (leaf-type thing)))) - (nlx-info *backend-t-primitive-type*) + (lambda-var + (if (lambda-var-indirect thing) + *backend-t-primitive-type* + (primitive-type (leaf-type thing)))) + (nlx-info *backend-t-primitive-type*) (clambda *backend-t-primitive-type*)))) - (push (cons thing (make-normal-tn ptype)) - reversed-ir2-physenv-alist))) + (push (cons thing (make-normal-tn ptype)) + reversed-ir2-physenv-alist))) (let ((res (make-ir2-physenv - :closure (nreverse reversed-ir2-physenv-alist) - :return-pc-pass (make-return-pc-passing-location - (xep-p clambda))))) + :closure (nreverse reversed-ir2-physenv-alist) + :return-pc-pass (make-return-pc-passing-location + (xep-p clambda))))) (setf (physenv-info lambda-physenv) res) (setf (ir2-physenv-old-fp res) - (make-old-fp-save-location lambda-physenv)) + (make-old-fp-save-location lambda-physenv)) (setf (ir2-physenv-return-pc res) - (make-return-pc-save-location lambda-physenv)))) + (make-return-pc-save-location lambda-physenv)))) (values)) @@ -94,11 +94,11 @@ (declare (type clambda fun)) (let ((return (lambda-return fun))) (and return - (do-uses (use (return-result return) nil) - (when (and (node-tail-p use) - (basic-combination-p use) - (eq (basic-combination-kind use) :full)) - (return t)))))) + (do-uses (use (return-result return) nil) + (when (and (node-tail-p use) + (basic-combination-p use) + (eq (basic-combination-kind use) :full)) + (return t)))))) ;;; Return true if we should use the standard (unknown) return ;;; convention for a TAIL-SET. We use the standard return convention @@ -112,17 +112,17 @@ (declare (type tail-set tails)) (let ((funs (tail-set-funs tails))) (or (and (find-if #'xep-p funs) - (find-if #'has-full-call-use funs)) - (block punt - (dolist (fun funs t) - (dolist (ref (leaf-refs fun)) - (let* ((lvar (node-lvar ref)) - (dest (and lvar (lvar-dest lvar)))) - (when (and (basic-combination-p dest) - (not (node-tail-p dest)) - (eq (basic-combination-fun dest) lvar) - (eq (basic-combination-kind dest) :local)) - (return-from punt nil))))))))) + (find-if #'has-full-call-use funs)) + (block punt + (dolist (fun funs t) + (dolist (ref (leaf-refs fun)) + (let* ((lvar (node-lvar ref)) + (dest (and lvar (lvar-dest lvar)))) + (when (and (basic-combination-p dest) + (not (node-tail-p dest)) + (eq (basic-combination-fun dest) lvar) + (eq (basic-combination-kind dest) :local)) + (return-from punt nil))))))))) ;;; If policy indicates, give an efficiency note about our inability to ;;; use the known return convention. We try to find a function in the @@ -132,28 +132,28 @@ (declare (type tail-set tails)) (let ((funs (tail-set-funs tails))) (when (policy (lambda-bind (first funs)) - (> (max speed space) - inhibit-warnings)) + (> (max speed space) + inhibit-warnings)) (dolist (fun funs - (let ((*compiler-error-context* (lambda-bind (first funs)))) - (compiler-notify - "Return value count mismatch prevents known return ~ + (let ((*compiler-error-context* (lambda-bind (first funs)))) + (compiler-notify + "Return value count mismatch prevents known return ~ from these functions:~ ~{~% ~A~}" - (mapcar #'leaf-source-name - (remove-if-not #'leaf-has-source-name-p funs))))) - (let ((ret (lambda-return fun))) - (when ret - (let ((rtype (return-result-type ret))) - (multiple-value-bind (ignore count) (values-types rtype) - (declare (ignore ignore)) - (when (eq count :unknown) - (let ((*compiler-error-context* (lambda-bind fun))) - (compiler-notify - "Return type not fixed values, so can't use known return ~ + (mapcar #'leaf-source-name + (remove-if-not #'leaf-has-source-name-p funs))))) + (let ((ret (lambda-return fun))) + (when ret + (let ((rtype (return-result-type ret))) + (multiple-value-bind (ignore count) (values-types rtype) + (declare (ignore ignore)) + (when (eq count :unknown) + (let ((*compiler-error-context* (lambda-bind fun))) + (compiler-notify + "Return type not fixed values, so can't use known return ~ convention:~% ~S" - (type-specifier rtype))) - (return))))))))) + (type-specifier rtype))) + (return))))))))) (values)) ;;; Return a RETURN-INFO structure describing how we should return @@ -165,18 +165,18 @@ (declare (type tail-set tails)) (multiple-value-bind (types count) (values-types (tail-set-type tails)) (let ((ptypes (mapcar #'primitive-type types)) - (use-standard (use-standard-returns tails))) + (use-standard (use-standard-returns tails))) (when (and (eq count :unknown) (not use-standard) (not (eq (tail-set-type tails) *empty-type*))) - (return-value-efficiency-note tails)) + (return-value-efficiency-note tails)) (if (or (eq count :unknown) use-standard) - (make-return-info :kind :unknown - :count count - :types ptypes) - (make-return-info :kind :fixed - :count count - :types ptypes - :locations (mapcar #'make-normal-tn ptypes)))))) + (make-return-info :kind :unknown + :count count + :types ptypes) + (make-return-info :kind :fixed + :count count + :types ptypes + :locations (mapcar #'make-normal-tn ptypes)))))) ;;; If TAIL-SET doesn't have any INFO, then make a RETURN-INFO for it. ;;; If we choose a return convention other than :UNKNOWN, and this @@ -186,15 +186,15 @@ (defun assign-return-locations (fun) (declare (type clambda fun)) (let* ((tails (lambda-tail-set fun)) - (returns (or (tail-set-info tails) - (setf (tail-set-info tails) - (return-info-for-set tails)))) - (return (lambda-return fun))) + (returns (or (tail-set-info tails) + (setf (tail-set-info tails) + (return-info-for-set tails)))) + (return (lambda-return fun))) (when (and return - (not (eq (return-info-kind returns) :unknown)) - (xep-p fun)) + (not (eq (return-info-kind returns) :unknown)) + (xep-p fun)) (do-uses (use (return-result return)) - (setf (node-tail-p use) nil)))) + (setf (node-tail-p use) nil)))) (values)) ;;; Make an IR2-NLX-INFO structure for each NLX entry point recorded. @@ -207,11 +207,11 @@ (let ((physenv (lambda-physenv fun))) (dolist (nlx (physenv-nlx-info physenv)) (setf (nlx-info-info nlx) - (make-ir2-nlx-info - :home (when (member (cleanup-kind (nlx-info-cleanup nlx)) - '(:block :tagbody)) + (make-ir2-nlx-info + :home (when (member (cleanup-kind (nlx-info-cleanup nlx)) + '(:block :tagbody)) (if (nlx-info-safe-p nlx) (make-normal-tn *backend-t-primitive-type*) (make-stack-pointer-tn))) - :save-sp (make-nlx-sp-tn physenv))))) + :save-sp (make-nlx-sp-tn physenv))))) (values)) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index b63a4a5..c835264 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -76,7 +76,7 @@ (defun note-if-setf-fun-and-macro (name) (when (consp name) (when (or (info :setf :inverse name) - (info :setf :expander name)) + (info :setf :expander name)) (compiler-style-warn "defining as a SETF function a name that already has a SETF macro:~ ~% ~S" @@ -88,8 +88,8 @@ (defun undefine-fun-name (name) (when name (macrolet ((frob (type &optional val) - `(unless (eq (info :function ,type name) ,val) - (setf (info :function ,type name) ,val)))) + `(unless (eq (info :function ,type name) ,val) + (setf (info :function ,type name) ,val)))) (frob :info) (frob :type (specifier-type 'function)) (frob :where-from :assumed) @@ -107,7 +107,7 @@ (when (eq (info :function :where-from name) :assumed) (setf (info :function :where-from name) :defined) (if (info :function :assumed-type name) - (setf (info :function :assumed-type name) nil)))) + (setf (info :function :assumed-type name) nil)))) ;;; Decode any raw (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR FUN-NAME) ;;; value into a lambda expression, or return NIL if there is none. @@ -115,8 +115,8 @@ (defun fun-name-inline-expansion (fun-name) (let ((info (info :function :inline-expansion-designator fun-name))) (if (functionp info) - (funcall info) - info))) + (funcall info) + info))) ;;;; ANSI Common Lisp functions which are defined in terms of the info ;;;; database @@ -152,15 +152,15 @@ environment only." (declare (symbol symbol)) (let* ((fenv (when env (sb!c::lexenv-funs env))) - (local-def (cdr (assoc symbol fenv)))) + (local-def (cdr (assoc symbol fenv)))) (cond (local-def - (if (and (consp local-def) (eq (car local-def) 'macro)) - (cdr local-def) - nil)) - ((eq (info :function :kind symbol) :macro) - (values (info :function :macro-function symbol))) - (t - nil)))) + (if (and (consp local-def) (eq (car local-def) 'macro)) + (cdr local-def) + nil)) + ((eq (info :function :kind symbol) :macro) + (values (info :function :macro-function symbol))) + (t + nil)))) (defun (setf sb!xc:macro-function) (function symbol &optional environment) (declare (symbol symbol) (type function function)) @@ -170,7 +170,7 @@ ;; supplying a non-nil one are undefined, we don't allow it. ;; (Thus our implementation of this unspecified behavior is to ;; complain. SInce the behavior is unspecified, this is conforming.:-) - (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S" + (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S" symbol environment)) (when (eq (info :function :kind symbol) :special-form) (error "~S names a special form." symbol)) @@ -182,11 +182,11 @@ ;; cross-compilation host's COMMON-LISP package. #-sb-xc-host (setf (symbol-function symbol) - (lambda (&rest args) - (declare (ignore args)) - ;; (ANSI specification of FUNCALL says that this should be - ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.) - (error 'undefined-function :name symbol))) + (lambda (&rest args) + (declare (ignore args)) + ;; (ANSI specification of FUNCALL says that this should be + ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.) + (error 'undefined-function :name symbol))) function) (defun sb!xc:compiler-macro-function (name &optional env) @@ -205,13 +205,13 @@ (values (info :function :compiler-macro-function name))) (defun (setf sb!xc:compiler-macro-function) (function name &optional env) (declare (type (or symbol list) name) - (type (or function null) function)) + (type (or function null) function)) (when env ;; ANSI says this operation is undefined. (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL")) (when (eq (info :function :kind name) :special-form) (error "~S names a special form." name)) - (with-single-package-locked-error + (with-single-package-locked-error (:symbol name "setting the compiler-macro-function of ~A") (setf (info :function :compiler-macro-function name) function) function)) @@ -236,45 +236,45 @@ ;;; and slamming them into PCL once PCL gets going. (defun fdocumentation (x doc-type) (flet ((try-cmucl-random-doc (x doc-type) - (declare (symbol doc-type)) - (cdr (assoc doc-type - (values (info :random-documentation :stuff x)))))) + (declare (symbol doc-type)) + (cdr (assoc doc-type + (values (info :random-documentation :stuff x)))))) (case doc-type (variable (typecase x - (symbol (values (info :variable :documentation x))))) + (symbol (values (info :variable :documentation x))))) (function (cond ((functionp x) - (%fun-doc x)) - ((legal-fun-name-p x) - ;; FIXME: Is it really right to make - ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to - ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL - ;; did, so we do it, but I'm not sure it's what ANSI wants. - (values (info :function :documentation - (fun-name-block-name x)))))) + (%fun-doc x)) + ((legal-fun-name-p x) + ;; FIXME: Is it really right to make + ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to + ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL + ;; did, so we do it, but I'm not sure it's what ANSI wants. + (values (info :function :documentation + (fun-name-block-name x)))))) (structure (typecase x - (symbol (when (eq (info :type :kind x) :instance) - (values (info :type :documentation x)))))) + (symbol (when (eq (info :type :kind x) :instance) + (values (info :type :documentation x)))))) (type (typecase x - (structure-class (values (info :type :documentation (class-name x)))) - (t (and (typep x 'symbol) (values (info :type :documentation x)))))) + (structure-class (values (info :type :documentation (class-name x)))) + (t (and (typep x 'symbol) (values (info :type :documentation x)))))) (setf (values (info :setf :documentation x))) ((t) (typecase x - (function (%fun-doc x)) - (package (package-doc-string x)) - (structure-class (values (info :type :documentation (class-name x)))) - (symbol (try-cmucl-random-doc x doc-type)))) + (function (%fun-doc x)) + (package (package-doc-string x)) + (structure-class (values (info :type :documentation (class-name x)))) + (symbol (try-cmucl-random-doc x doc-type)))) (t (typecase x - ;; FIXME: This code comes from CMU CL, but - ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere - ;; in CMU CL. Perhaps it could be defined by analogy with the - ;; corresponding SETF FDOCUMENTATION code. - (symbol (try-cmucl-random-doc x doc-type))))))) + ;; FIXME: This code comes from CMU CL, but + ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere + ;; in CMU CL. Perhaps it could be defined by analogy with the + ;; corresponding SETF FDOCUMENTATION code. + (symbol (try-cmucl-random-doc x doc-type))))))) (defun (setf fdocumentation) (string name doc-type) ;; FIXME: I think it should be possible to set documentation for ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp @@ -284,14 +284,14 @@ (variable (setf (info :variable :documentation name) string)) (function (setf (info :function :documentation name) string)) (structure (if (eq (info :type :kind name) :instance) - (setf (info :type :documentation name) string) - (error "~S is not the name of a structure type." name))) + (setf (info :type :documentation name) string) + (error "~S is not the name of a structure type." name))) (type (setf (info :type :documentation name) string)) (setf (setf (info :setf :documentation name) string)) (t (let ((pair (assoc doc-type (info :random-documentation :stuff name)))) (if pair - (setf (cdr pair) string) - (push (cons doc-type string) - (info :random-documentation :stuff name)))))) + (setf (cdr pair) string) + (push (cons doc-type string) + (info :random-documentation :stuff name)))))) string) diff --git a/src/compiler/ir1-step.lisp b/src/compiler/ir1-step.lisp index 8f852fe..3d3bf41 100644 --- a/src/compiler/ir1-step.lisp +++ b/src/compiler/ir1-step.lisp @@ -32,7 +32,7 @@ (setf *stepping* nil)) (step-next () nil) - (step-into () + (step-into () t)))) (defun step-variable (symbol value) @@ -47,8 +47,8 @@ (defun insert-step-conditions (form) `(locally (declare - (optimize (insert-step-conditions - ,(policy *lexenv* insert-step-conditions)))) + (optimize (insert-step-conditions + ,(policy *lexenv* insert-step-conditions)))) ,form)) ;;; Flag to control instrumentation function call arguments. @@ -84,8 +84,8 @@ #+sb-xc-host (declare (ignore form)) #-sb-xc-host (flet ((step-symbol-p (symbol) - (not (member (symbol-package symbol) - (load-time-value + (not (member (symbol-package symbol) + (load-time-value ;; KLUDGE: packages we're not interested in stepping. (mapcar #'find-package '(sb!c sb!int sb!impl sb!kernel sb!pcl))))))) (let ((lexenv *lexenv*)) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 88f8ff3..7f20043 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -28,13 +28,13 @@ otherwise evaluate Else and return its values. Else defaults to NIL." (let* ((pred-ctran (make-ctran)) (pred-lvar (make-lvar)) - (then-ctran (make-ctran)) - (then-block (ctran-starts-block then-ctran)) - (else-ctran (make-ctran)) - (else-block (ctran-starts-block else-ctran)) - (node (make-if :test pred-lvar - :consequent then-block - :alternative else-block))) + (then-ctran (make-ctran)) + (then-block (ctran-starts-block then-ctran)) + (else-ctran (make-ctran)) + (else-block (ctran-starts-block else-ctran)) + (node (make-if :test pred-lvar + :consequent then-block + :alternative else-block))) ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the ;; order of the following two forms is important (setf (lvar-dest pred-lvar) node) @@ -72,9 +72,9 @@ (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) - (entry (make-entry)) - (cleanup (make-cleanup :kind :block - :mess-up entry))) + (entry (make-entry)) + (cleanup (make-cleanup :kind :block + :mess-up entry))) (push entry (lambda-entries (lexenv-lambda *lexenv*))) (setf (entry-cleanup entry) cleanup) (link-node-to-previous-ctran entry start) @@ -82,7 +82,7 @@ (let* ((env-entry (list entry next result)) (*lexenv* (make-lexenv :blocks (list (cons name env-entry)) - :cleanup cleanup))) + :cleanup cleanup))) (ir1-convert-progn-body dummy next result forms)))) (def-ir1-translator return-from ((name &optional value) start next result) @@ -108,13 +108,13 @@ (declare (ignore result)) (ctran-starts-block next) (let* ((found (or (lexenv-find name blocks) - (compiler-error "return for unknown block: ~S" name))) + (compiler-error "return for unknown block: ~S" name))) (exit-ctran (second found)) - (value-ctran (make-ctran)) + (value-ctran (make-ctran)) (value-lvar (make-lvar)) - (entry (first found)) - (exit (make-exit :entry entry - :value value-lvar))) + (entry (first found)) + (exit (make-exit :entry entry + :value value-lvar))) (when (ctran-deleted-p exit-ctran) (throw 'locall-already-let-converted exit-ctran)) (push exit (entry-exits entry)) @@ -123,7 +123,7 @@ (link-node-to-previous-ctran exit value-ctran) (let ((home-lambda (ctran-home-lambda-or-null start))) (when home-lambda - (push entry (lambda-calls-or-closes home-lambda)))) + (push entry (lambda-calls-or-closes home-lambda)))) (use-continuation exit exit-ctran (third found)))) ;;; Return a list of the segments of a TAGBODY. Each segment looks @@ -138,19 +138,19 @@ (collect ((segments)) (let ((current (cons nil body))) (loop - (let ((tag-pos (position-if (complement #'listp) current :start 1))) - (unless tag-pos - (segments `(,@current nil)) - (return)) - (let ((tag (elt current tag-pos))) - (when (assoc tag (segments)) - (compiler-error - "The tag ~S appears more than once in the tagbody." - tag)) - (unless (or (symbolp tag) (integerp tag)) - (compiler-error "~S is not a legal tagbody statement." tag)) - (segments `(,@(subseq current 0 tag-pos) (go ,tag)))) - (setq current (nthcdr tag-pos current))))) + (let ((tag-pos (position-if (complement #'listp) current :start 1))) + (unless tag-pos + (segments `(,@current nil)) + (return)) + (let ((tag (elt current tag-pos))) + (when (assoc tag (segments)) + (compiler-error + "The tag ~S appears more than once in the tagbody." + tag)) + (unless (or (symbolp tag) (integerp tag)) + (compiler-error "~S is not a legal tagbody statement." tag)) + (segments `(,@(subseq current 0 tag-pos) (go ,tag)))) + (setq current (nthcdr tag-pos current))))) (segments))) ;;; Set up the cleanup, emitting the entry node. Then make a block for @@ -169,34 +169,34 @@ (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) - (entry (make-entry)) - (segments (parse-tagbody statements)) - (cleanup (make-cleanup :kind :tagbody - :mess-up entry))) + (entry (make-entry)) + (segments (parse-tagbody statements)) + (cleanup (make-cleanup :kind :tagbody + :mess-up entry))) (push entry (lambda-entries (lexenv-lambda *lexenv*))) (setf (entry-cleanup entry) cleanup) (link-node-to-previous-ctran entry start) (use-ctran entry dummy) (collect ((tags) - (starts) - (ctrans)) + (starts) + (ctrans)) (starts dummy) (dolist (segment (rest segments)) - (let* ((tag-ctran (make-ctran)) + (let* ((tag-ctran (make-ctran)) (tag (list (car segment) entry tag-ctran))) - (ctrans tag-ctran) - (starts tag-ctran) - (ctran-starts-block tag-ctran) + (ctrans tag-ctran) + (starts tag-ctran) + (ctran-starts-block tag-ctran) (tags tag))) (ctrans next) (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags)))) - (mapc (lambda (segment start end) - (ir1-convert-progn-body start end + (mapc (lambda (segment start end) + (ir1-convert-progn-body start end (when (eq end next) result) (rest segment))) - segments (starts) (ctrans)))))) + segments (starts) (ctrans)))))) ;;; Emit an EXIT node without any value. (def-ir1-translator go ((tag) start next result) @@ -206,15 +206,15 @@ is constrained to be used only within the dynamic extent of the TAGBODY." (ctran-starts-block next) (let* ((found (or (lexenv-find tag tags :test #'eql) - (compiler-error "attempt to GO to nonexistent tag: ~S" - tag))) - (entry (first found)) - (exit (make-exit :entry entry))) + (compiler-error "attempt to GO to nonexistent tag: ~S" + tag))) + (entry (first found)) + (exit (make-exit :entry entry))) (push exit (entry-exits entry)) (link-node-to-previous-ctran exit start) (let ((home-lambda (ctran-home-lambda-or-null start))) (when home-lambda - (push entry (lambda-calls-or-closes home-lambda)))) + (push entry (lambda-calls-or-closes home-lambda)))) (use-ctran exit (second found)))) ;;;; translators for compiler-magic special forms @@ -247,9 +247,9 @@ ;;; in-lexenv representation, stuff the results into *LEXENV*, and ;;; call FUN (with no arguments). (defun %funcall-in-foomacrolet-lexenv (definitionize-fun - definitionize-keyword - definitions - fun) + definitionize-keyword + definitions + fun) (declare (type function definitionize-fun fun)) (declare (type (member :vars :funs) definitionize-keyword)) (declare (type list definitions)) @@ -271,9 +271,9 @@ ;;; EVAL can likewise make use of it. (defun macrolet-definitionize-fun (context lexenv) (flet ((fail (control &rest args) - (ecase context - (:compile (apply #'compiler-error control args)) - (:eval (error 'simple-program-error + (ecase context + (:compile (apply #'compiler-error control args)) + (:eval (error 'simple-program-error :format-control control :format-arguments args))))) (lambda (definition) @@ -283,8 +283,8 @@ (destructuring-bind (name arglist &body body) definition (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) - (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked + (when (fboundp name) + (compiler-assert-symbol-home-package-unlocked name "binding ~A as a local macro")) (unless (listp arglist) (fail "The local macro argument list ~S is not a list." @@ -323,9 +323,9 @@ (defun symbol-macrolet-definitionize-fun (context) (flet ((fail (control &rest args) - (ecase context - (:compile (apply #'compiler-error control args)) - (:eval (error 'simple-program-error + (ecase context + (:compile (apply #'compiler-error control args)) + (:eval (error 'simple-program-error :format-control control :format-arguments args))))) (lambda (definition) @@ -334,14 +334,14 @@ (destructuring-bind (name expansion) definition (unless (symbolp name) (fail "The local symbol macro name ~S is not a symbol." name)) - (when (or (boundp name) (eq (info :variable :kind name) :macro)) - (compiler-assert-symbol-home-package-unlocked + (when (or (boundp name) (eq (info :variable :kind name) :macro)) + (compiler-assert-symbol-home-package-unlocked name "binding ~A as a local symbol-macro")) (let ((kind (info :variable :kind name))) (when (member kind '(:special :constant)) (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name))) - ;; A magical cons that MACROEXPAND-1 understands. + ;; A magical cons that MACROEXPAND-1 understands. `(,name . (macro . ,expansion)))))) (defun funcall-in-symbol-macrolet-lexenv (definitions fun context) @@ -374,7 +374,7 @@ (handler-case (mapcar #'eval args) (error (condition) (compiler-error "Lisp error during evaluation of info args:~%~A" - condition)))) + condition)))) ;;; Convert to the %%PRIMITIVE funny function. The first argument is ;;; the template, the second is a list of the results of any @@ -394,24 +394,24 @@ (def-ir1-translator %primitive ((name &rest args) start next result) (declare (type symbol name)) (let* ((template (or (gethash name *backend-template-names*) - (bug "undefined primitive ~A" name))) - (required (length (template-arg-types template))) - (info (template-info-arg-count template)) - (min (+ required info)) - (nargs (length args))) + (bug "undefined primitive ~A" name))) + (required (length (template-arg-types template))) + (info (template-info-arg-count template)) + (min (+ required info)) + (nargs (length args))) (if (template-more-args-type template) - (when (< nargs min) - (bug "Primitive ~A was called with ~R argument~:P, ~ + (when (< nargs min) + (bug "Primitive ~A was called with ~R argument~:P, ~ but wants at least ~R." - name - nargs - min)) - (unless (= nargs min) - (bug "Primitive ~A was called with ~R argument~:P, ~ + name + nargs + min)) + (unless (= nargs min) + (bug "Primitive ~A was called with ~R argument~:P, ~ but wants exactly ~R." - name - nargs - min))) + name + nargs + min))) (when (eq (template-result-types template) :conditional) (bug "%PRIMITIVE was used with a conditional template.")) @@ -420,11 +420,11 @@ (bug "%PRIMITIVE was used with an unknown values template.")) (ir1-convert start next result - `(%%primitive ',template - ',(eval-info-args - (subseq args required min)) - ,@(subseq args 0 required) - ,@(subseq args min))))) + `(%%primitive ',template + ',(eval-info-args + (subseq args required min)) + ,@(subseq args 0 required) + ,@(subseq args min))))) ;;;; QUOTE @@ -447,18 +447,18 @@ (defun fun-name-leaf (thing) (if (consp thing) (cond - ((member (car thing) - '(lambda named-lambda instance-lambda lambda-with-lexenv)) - (values (ir1-convert-lambdalike + ((member (car thing) + '(lambda named-lambda instance-lambda lambda-with-lexenv)) + (values (ir1-convert-lambdalike thing :debug-name (name-lambdalike thing)) t)) - ((legal-fun-name-p thing) - (values (find-lexically-apparent-fun + ((legal-fun-name-p thing) + (values (find-lexically-apparent-fun thing "as the argument to FUNCTION") nil)) - (t - (compiler-error "~S is not a legal function name." thing))) + (t + (compiler-error "~S is not a legal function name." thing))) (values (find-lexically-apparent-fun thing "as the argument to FUNCTION") nil))) @@ -498,10 +498,10 @@ (let ((arg-names (make-gensym-list (length args)))) `(lambda (function ,@arg-names) (%funcall ,(if (csubtypep (lvar-type function) - (specifier-type 'function)) - 'function - '(%coerce-callable-to-fun function)) - ,@arg-names)))) + (specifier-type 'function)) + 'function + '(%coerce-callable-to-fun function)) + ,@arg-names)))) (def-ir1-translator %funcall ((function &rest args) start next result) (if (and (consp function) (eq (car function) 'function)) @@ -539,35 +539,35 @@ ;;; variables are marked as such. Context is the name of the form, for ;;; error reporting purposes. (declaim (ftype (function (list symbol) (values list list)) - extract-let-vars)) + extract-let-vars)) (defun extract-let-vars (bindings context) (collect ((vars) - (vals) - (names)) + (vals) + (names)) (flet ((get-var (name) - (varify-lambda-arg name - (if (eq context 'let*) - nil - (names))))) + (varify-lambda-arg name + (if (eq context 'let*) + nil + (names))))) (dolist (spec bindings) - (cond ((atom spec) - (let ((var (get-var spec))) - (vars var) - (names spec) - (vals nil))) - (t - (unless (proper-list-of-length-p spec 1 2) - (compiler-error "The ~S binding spec ~S is malformed." - context - spec)) - (let* ((name (first spec)) - (var (get-var name))) - (vars var) - (names name) - (vals (second spec))))))) + (cond ((atom spec) + (let ((var (get-var spec))) + (vars var) + (names spec) + (vals nil))) + (t + (unless (proper-list-of-length-p spec 1 2) + (compiler-error "The ~S binding spec ~S is malformed." + context + spec)) + (let* ((name (first spec)) + (var (get-var name))) + (vars var) + (names name) + (vals (second spec))))))) (dolist (name (names)) (when (eq (info :variable :kind name) :macro) - (compiler-assert-symbol-home-package-unlocked + (compiler-assert-symbol-home-package-unlocked name "lexically binding symbol-macro ~A"))) (values (vars) (vals)))) @@ -587,11 +587,11 @@ (fun-lvar (make-lvar)) ((next result) (processing-decls (decls vars nil next result - post-binding-lexenv) + post-binding-lexenv) (let ((fun (ir1-convert-lambda-body forms vars - :post-binding-lexenv post-binding-lexenv + :post-binding-lexenv post-binding-lexenv :debug-name (debug-name 'let bindings)))) (reference-leaf start ctran fun-lvar fun)) (values next result)))) @@ -600,7 +600,7 @@ (compiler-error "Malformed LET bindings: ~S." bindings)))) (def-ir1-translator let* ((bindings &body body) - start next result) + start next result) #!+sb-doc "LET* ({(Var [Value]) | Var}*) Declaration* Form* Similar to LET, but the variables are bound sequentially, allowing each Value @@ -616,7 +616,7 @@ forms vars values - post-binding-lexenv)))) + post-binding-lexenv)))) (compiler-error "Malformed LET* bindings: ~S." bindings))) ;;; logic shared between IR1 translators for LOCALLY, MACROLET, @@ -652,22 +652,22 @@ (declaim (ftype (function (list symbol) (values list list)) extract-flet-vars)) (defun extract-flet-vars (definitions context) (collect ((names) - (defs)) + (defs)) (dolist (def definitions) (when (or (atom def) (< (length def) 2)) - (compiler-error "The ~S definition spec ~S is malformed." context def)) + (compiler-error "The ~S definition spec ~S is malformed." context def)) (let ((name (first def))) - (check-fun-name name) - (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked + (check-fun-name name) + (when (fboundp name) + (compiler-assert-symbol-home-package-unlocked name "binding ~A as a local function")) - (names name) - (multiple-value-bind (forms decls) (parse-body (cddr def)) - (defs `(lambda ,(second def) - ,@decls - (block ,(fun-name-block-name name) - . ,forms)))))) + (names name) + (multiple-value-bind (forms decls) (parse-body (cddr def)) + (defs `(lambda ,(second def) + ,@decls + (block ,(fun-name-block-name name) + . ,forms)))))) (values (names) (defs)))) (defun ir1-convert-fbindings (start next result funs body) @@ -694,7 +694,7 @@ (t (ir1-convert-progn-body ctran next result body))))) (def-ir1-translator flet ((definitions &body body) - start next result) + start next result) #!+sb-doc "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* Evaluate the Body-Forms with some local function definitions. The bindings @@ -727,8 +727,8 @@ (placeholder-funs (mapcar (lambda (name) (make-functional :%source-name name - :%debug-name (debug-name - 'labels-placeholder + :%debug-name (debug-name + 'labels-placeholder name))) names)) ;; (like PAIRLIS but guaranteed to preserve ordering:) @@ -798,7 +798,7 @@ "" #-nil (let ((type (coerce-to-values (compiler-values-specifier-type type))) - (old (when result (find-uses result)))) + (old (when result (find-uses result)))) (ir1-convert start next result value) (when result (do-uses (use result) @@ -817,37 +817,37 @@ (when (oddp len) (compiler-error "odd number of args to SETQ: ~S" source)) (if (= len 2) - (let* ((name (first things)) - (leaf (or (lexenv-find name vars) - (find-free-var name)))) - (etypecase leaf - (leaf - (when (constant-p leaf) - (compiler-error "~S is a constant and thus can't be set." name)) - (when (lambda-var-p leaf) - (let ((home-lambda (ctran-home-lambda-or-null start))) - (when home-lambda - (pushnew leaf (lambda-calls-or-closes home-lambda)))) - (when (lambda-var-ignorep leaf) - ;; ANSI's definition of "Declaration IGNORE, IGNORABLE" - ;; requires that this be a STYLE-WARNING, not a full warning. - (compiler-style-warn - "~S is being set even though it was declared to be ignored." - name))) - (setq-var start next result leaf (second things))) - (cons - (aver (eq (car leaf) 'macro)) + (let* ((name (first things)) + (leaf (or (lexenv-find name vars) + (find-free-var name)))) + (etypecase leaf + (leaf + (when (constant-p leaf) + (compiler-error "~S is a constant and thus can't be set." name)) + (when (lambda-var-p leaf) + (let ((home-lambda (ctran-home-lambda-or-null start))) + (when home-lambda + (pushnew leaf (lambda-calls-or-closes home-lambda)))) + (when (lambda-var-ignorep leaf) + ;; ANSI's definition of "Declaration IGNORE, IGNORABLE" + ;; requires that this be a STYLE-WARNING, not a full warning. + (compiler-style-warn + "~S is being set even though it was declared to be ignored." + name))) + (setq-var start next result leaf (second things))) + (cons + (aver (eq (car leaf) 'macro)) ;; FIXME: [Free] type declaration. -- APD, 2002-01-26 - (ir1-convert start next result + (ir1-convert start next result `(setf ,(cdr leaf) ,(second things)))) - (heap-alien-info - (ir1-convert start next result - `(%set-heap-alien ',leaf ,(second things)))))) - (collect ((sets)) - (do ((thing things (cddr thing))) - ((endp thing) - (ir1-convert-progn-body start next result (sets))) - (sets `(setq ,(first thing) ,(second thing)))))))) + (heap-alien-info + (ir1-convert start next result + `(%set-heap-alien ',leaf ,(second things)))))) + (collect ((sets)) + (do ((thing things (cddr thing))) + ((endp thing) + (ir1-convert-progn-body start next result (sets))) + (sets `(setq ,(first thing) ,(second thing)))))))) ;;; This is kind of like REFERENCE-LEAF, but we generate a SET node. ;;; This should only need to be called in SETQ. @@ -877,7 +877,7 @@ Do a non-local exit, return the values of Form from the CATCH whose tag evaluates to the same thing as Tag." (ir1-convert start next result-lvar - `(multiple-value-call #'%throw ,tag ,result))) + `(multiple-value-call #'%throw ,tag ,result))) ;;; This is a special special form used to instantiate a cleanup as ;;; the current cleanup within the body. KIND is the kind of cleanup @@ -889,13 +889,13 @@ (def-ir1-translator %within-cleanup ((kind mess-up &body body) start next result) (let ((dummy (make-ctran)) - (dummy2 (make-ctran))) + (dummy2 (make-ctran))) (ir1-convert start dummy nil mess-up) (let* ((mess-node (ctran-use dummy)) - (cleanup (make-cleanup :kind kind - :mess-up mess-node)) - (old-cup (lexenv-cleanup *lexenv*)) - (*lexenv* (make-lexenv :cleanup cleanup))) + (cleanup (make-cleanup :kind kind + :mess-up mess-node)) + (old-cup (lexenv-cleanup *lexenv*)) + (*lexenv* (make-lexenv :cleanup cleanup))) (setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup) (ir1-convert dummy dummy2 nil '(%cleanup-point)) (ir1-convert-progn-body dummy2 next result body)))) @@ -943,9 +943,9 @@ start next result (with-unique-names (exit-block) `(block ,exit-block - (%within-cleanup - :catch (%catch (%escape-fun ,exit-block) ,tag) - ,@body))))) + (%within-cleanup + :catch (%catch (%escape-fun ,exit-block) ,tag) + ,@body))))) (def-ir1-translator unwind-protect ((protected &body cleanup) start next result) @@ -964,20 +964,20 @@ start next result (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count) `(flet ((,cleanup-fun () ,@cleanup nil)) - ;; FIXME: If we ever get DYNAMIC-EXTENT working, then - ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT, - ;; and something can be done to make %ESCAPE-FUN have - ;; dynamic extent too. - (block ,drop-thru-tag - (multiple-value-bind (,next ,start ,count) - (block ,exit-tag - (%within-cleanup - :unwind-protect - (%unwind-protect (%escape-fun ,exit-tag) - (%cleanup-fun ,cleanup-fun)) - (return-from ,drop-thru-tag ,protected))) - (,cleanup-fun) - (%continue-unwind ,next ,start ,count))))))) + ;; FIXME: If we ever get DYNAMIC-EXTENT working, then + ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT, + ;; and something can be done to make %ESCAPE-FUN have + ;; dynamic extent too. + (block ,drop-thru-tag + (multiple-value-bind (,next ,start ,count) + (block ,exit-tag + (%within-cleanup + :unwind-protect + (%unwind-protect (%escape-fun ,exit-tag) + (%cleanup-fun ,cleanup-fun)) + (return-from ,drop-thru-tag ,protected))) + (,cleanup-fun) + (%continue-unwind ,next ,start ,count))))))) ;;;; multiple-value stuff @@ -988,33 +988,33 @@ values from the first VALUES-FORM making up the first argument, etc." (let* ((ctran (make-ctran)) (fun-lvar (make-lvar)) - (node (if args - ;; If there are arguments, MULTIPLE-VALUE-CALL - ;; turns into an MV-COMBINATION. - (make-mv-combination fun-lvar) - ;; If there are no arguments, then we convert to a - ;; normal combination, ensuring that a MV-COMBINATION - ;; always has at least one argument. This can be - ;; regarded as an optimization, but it is more - ;; important for simplifying compilation of - ;; MV-COMBINATIONS. - (make-combination fun-lvar)))) + (node (if args + ;; If there are arguments, MULTIPLE-VALUE-CALL + ;; turns into an MV-COMBINATION. + (make-mv-combination fun-lvar) + ;; If there are no arguments, then we convert to a + ;; normal combination, ensuring that a MV-COMBINATION + ;; always has at least one argument. This can be + ;; regarded as an optimization, but it is more + ;; important for simplifying compilation of + ;; MV-COMBINATIONS. + (make-combination fun-lvar)))) (ir1-convert start ctran fun-lvar - (if (and (consp fun) (eq (car fun) 'function)) - fun - `(%coerce-callable-to-fun ,fun))) + (if (and (consp fun) (eq (car fun) 'function)) + fun + `(%coerce-callable-to-fun ,fun))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) (let ((this-start ctran)) - (dolist (arg args) - (let ((this-ctran (make-ctran)) + (dolist (arg args) + (let ((this-ctran (make-ctran)) (this-lvar (make-lvar node))) - (ir1-convert this-start this-ctran this-lvar arg) - (setq this-start this-ctran) - (arg-lvars this-lvar))) - (link-node-to-previous-ctran node this-start) - (use-continuation node next result) - (setf (basic-combination-args node) (arg-lvars)))))) + (ir1-convert this-start this-ctran this-lvar arg) + (setq this-start this-ctran) + (arg-lvars this-lvar))) + (link-node-to-previous-ctran node this-start) + (use-continuation node next result) + (setf (basic-combination-args node) (arg-lvars)))))) (def-ir1-translator multiple-value-prog1 ((values-form &rest forms) start next result) @@ -1045,5 +1045,5 @@ ((null path) *current-path*) (let ((first (first path))) (when (or (eq first name) - (eq first 'original-source-start)) - (return path))))) + (eq first 'original-source-start)) + (return path))))) diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index b2c55f0..8d0e0ca 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -20,36 +20,36 @@ (defun note-failed-optimization (node failures) (declare (type combination node) (list failures)) (unless (or (node-deleted node) - (not (eq :known (combination-kind node)))) + (not (eq :known (combination-kind node)))) (let ((*compiler-error-context* node)) (dolist (failure failures) - (let ((what (cdr failure)) - (note (transform-note (car failure)))) - (cond - ((consp what) - (compiler-notify "~@" - note (first what) (rest what))) - ((valid-fun-use node what - :argument-test #'types-equal-or-intersect - :result-test #'values-types-equal-or-intersect) - (collect ((messages)) - (flet ((give-grief (string &rest stuff) - (messages string) - (messages stuff))) - (valid-fun-use node what - :unwinnage-fun #'give-grief - :lossage-fun #'give-grief)) - (compiler-notify "~@" + note (first what) (rest what))) + ((valid-fun-use node what + :argument-test #'types-equal-or-intersect + :result-test #'values-types-equal-or-intersect) + (collect ((messages)) + (flet ((give-grief (string &rest stuff) + (messages string) + (messages stuff))) + (valid-fun-use node what + :unwinnage-fun #'give-grief + :lossage-fun #'give-grief)) + (compiler-notify "~@" - note (messages)))) - ;; As best I can guess, it's OK to fall off the end here - ;; because if it's not a VALID-FUNCTION-USE, the user - ;; doesn't want to hear about it. The things I caught when - ;; I put ERROR "internal error: unexpected FAILURE=~S" here - ;; didn't look like things we need to report. -- WHN 2001-02-07 - )))))) + note (messages)))) + ;; As best I can guess, it's OK to fall off the end here + ;; because if it's not a VALID-FUNCTION-USE, the user + ;; doesn't want to hear about it. The things I caught when + ;; I put ERROR "internal error: unexpected FAILURE=~S" here + ;; didn't look like things we need to report. -- WHN 2001-02-07 + )))))) ;;; For each named function with an XEP, note the definition of that ;;; name, and add derived type information to the INFO environment. We @@ -57,37 +57,37 @@ ;;; possibility that new references might be converted to it. (defun finalize-xep-definition (fun) (let* ((leaf (functional-entry-fun fun)) - (defined-ftype (definition-type leaf))) + (defined-ftype (definition-type leaf))) (setf (leaf-type leaf) defined-ftype) (when (and (leaf-has-source-name-p leaf) - (eq (leaf-source-name leaf) (functional-debug-name leaf))) + (eq (leaf-source-name leaf) (functional-debug-name leaf))) (let ((source-name (leaf-source-name leaf))) - (let* ((where (info :function :where-from source-name)) - (*compiler-error-context* (lambda-bind (main-entry leaf))) - (global-def (gethash source-name *free-funs*)) - (global-p (defined-fun-p global-def))) - (note-name-defined source-name :function) - (when global-p - (remhash source-name *free-funs*)) - (ecase where - (:assumed - (let ((approx-type (info :function :assumed-type source-name))) - (when (and approx-type (fun-type-p defined-ftype)) - (valid-approximate-type approx-type defined-ftype)) - (setf (info :function :type source-name) defined-ftype) - (setf (info :function :assumed-type source-name) nil)) - (setf (info :function :where-from source-name) :defined)) - (:declared - (let ((declared-ftype (info :function :type source-name))) - (unless (defined-ftype-matches-declared-ftype-p - defined-ftype declared-ftype) - (compiler-style-warn + (let* ((where (info :function :where-from source-name)) + (*compiler-error-context* (lambda-bind (main-entry leaf))) + (global-def (gethash source-name *free-funs*)) + (global-p (defined-fun-p global-def))) + (note-name-defined source-name :function) + (when global-p + (remhash source-name *free-funs*)) + (ecase where + (:assumed + (let ((approx-type (info :function :assumed-type source-name))) + (when (and approx-type (fun-type-p defined-ftype)) + (valid-approximate-type approx-type defined-ftype)) + (setf (info :function :type source-name) defined-ftype) + (setf (info :function :assumed-type source-name) nil)) + (setf (info :function :where-from source-name) :defined)) + (:declared + (let ((declared-ftype (info :function :type source-name))) + (unless (defined-ftype-matches-declared-ftype-p + defined-ftype declared-ftype) + (compiler-style-warn "~@" (type-specifier declared-ftype) (type-specifier defined-ftype))))) - (:defined - (setf (info :function :type source-name) defined-ftype))))))) + (:defined + (setf (info :function :type source-name) defined-ftype))))))) (values)) ;;; Find all calls in COMPONENT to assumed functions and update the @@ -96,17 +96,17 @@ ;;; types. (defun note-assumed-types (component name var) (when (and (eq (leaf-where-from var) :assumed) - (not (and (defined-fun-p var) - (eq (defined-fun-inlinep var) :notinline))) - (eq (info :function :where-from name) :assumed) - (eq (info :function :kind name) :function)) + (not (and (defined-fun-p var) + (eq (defined-fun-inlinep var) :notinline))) + (eq (info :function :where-from name) :assumed) + (eq (info :function :kind name) :function)) (let ((atype (info :function :assumed-type name))) (dolist (ref (leaf-refs var)) - (let ((dest (node-dest ref))) - (when (and (eq (node-component ref) component) - (combination-p dest) - (eq (lvar-uses (basic-combination-fun dest)) ref)) - (setq atype (note-fun-use dest atype))))) + (let ((dest (node-dest ref))) + (when (and (eq (node-component ref) component) + (combination-p dest) + (eq (lvar-uses (basic-combination-fun dest)) ref)) + (setq atype (note-fun-use dest atype))))) (setf (info :function :assumed-type name) atype)))) ;;; Merge CASTs with preceding/following nodes. @@ -151,11 +151,11 @@ (setf (leaf-type fun) (definition-type fun))))) (maphash #'note-failed-optimization - (component-failed-optimizations component)) + (component-failed-optimizations component)) (maphash (lambda (k v) - (note-assumed-types component k v)) - *free-funs*) + (note-assumed-types component k v)) + *free-funs*) (ir1-merge-casts component) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 34117f5..feadc4d 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -165,16 +165,16 @@ (unless (eq node-type rtype) (let ((int (values-type-intersection node-type rtype)) (lvar (node-lvar node))) - (when (type/= node-type int) - (when (and *check-consistency* - (eq int *empty-type*) - (not (eq rtype *empty-type*))) - (let ((*compiler-error-context* node)) - (compiler-warn - "New inferred type ~S conflicts with old type:~ + (when (type/= node-type int) + (when (and *check-consistency* + (eq int *empty-type*) + (not (eq rtype *empty-type*))) + (let ((*compiler-error-context* node)) + (compiler-warn + "New inferred type ~S conflicts with old type:~ ~% ~S~%*** possible internal error? Please report this." - (type-specifier rtype) (type-specifier node-type)))) - (setf (node-derived-type node) int) + (type-specifier rtype) (type-specifier node-type)))) + (setf (node-derived-type node) int) ;; If the new type consists of only one object, replace the ;; node with a constant reference. (when (and (ref-p node) @@ -184,7 +184,7 @@ (null (rest (member-type-members type)))) (change-ref-leaf node (find-constant (first (member-type-members type))))))) - (reoptimize-lvar lvar))))) + (reoptimize-lvar lvar))))) (values)) ;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an @@ -281,31 +281,31 @@ ;; As above, we clear the node REOPTIMIZE flag before optimizing. (setf (node-reoptimize node) nil) (typecase node - (ref) - (combination - ;; With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever - ;; the function changes, and call IR1-OPTIMIZE-COMBINATION if - ;; any argument changes. - (ir1-optimize-combination node)) - (cif - (ir1-optimize-if node)) - (creturn - ;; KLUDGE: We leave the NODE-OPTIMIZE flag set going into - ;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to - ;; clear the flag itself. -- WHN 2002-02-02, quoting original - ;; CMU CL comments - (setf (node-reoptimize node) t) - (ir1-optimize-return node)) - (mv-combination - (ir1-optimize-mv-combination node)) - (exit - ;; With an EXIT, we derive the node's type from the VALUE's - ;; type. - (let ((value (exit-value node))) - (when value - (derive-node-type node (lvar-derived-type value))))) - (cset - (ir1-optimize-set node)) + (ref) + (combination + ;; With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever + ;; the function changes, and call IR1-OPTIMIZE-COMBINATION if + ;; any argument changes. + (ir1-optimize-combination node)) + (cif + (ir1-optimize-if node)) + (creturn + ;; KLUDGE: We leave the NODE-OPTIMIZE flag set going into + ;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to + ;; clear the flag itself. -- WHN 2002-02-02, quoting original + ;; CMU CL comments + (setf (node-reoptimize node) t) + (ir1-optimize-return node)) + (mv-combination + (ir1-optimize-mv-combination node)) + (exit + ;; With an EXIT, we derive the node's type from the VALUE's + ;; type. + (let ((value (exit-value node))) + (when value + (derive-node-type node (lvar-derived-type value))))) + (cset + (ir1-optimize-set node)) (cast (ir1-optimize-cast node))))) @@ -337,7 +337,7 @@ (let ((last (block-last block))) (and (valued-node-p last) (awhen (node-lvar last) - (or + (or ;; ... and a DX-allocator to end a block. (lvar-dynamic-extent it) ;; FIXME: This is a partial workaround for bug 303. @@ -354,10 +354,10 @@ (declare (type cblock block1 block2)) (let* ((last1 (block-last block1)) (last2 (block-last block2)) - (succ (block-succ block2)) - (start2 (block-start block2))) + (succ (block-succ block2)) + (start2 (block-start block2))) (do ((ctran start2 (node-next (ctran-next ctran)))) - ((not ctran)) + ((not ctran)) (setf (ctran-block ctran) block1)) (unlink-blocks block1 block2) @@ -371,12 +371,12 @@ (setf (block-last block1) last2)) (setf (block-flags block1) - (attributes-union (block-flags block1) - (block-flags block2) - (block-attributes type-asserted test-modified))) + (attributes-union (block-flags block1) + (block-flags block2) + (block-attributes type-asserted test-modified))) (let ((next (block-next block2)) - (prev (block-prev block2))) + (prev (block-prev block2))) (setf (block-next prev) next) (setf (block-prev next) prev)) @@ -391,46 +391,46 @@ (do-nodes-backwards (node lvar block :restart-p t) (unless lvar (typecase node - (ref - (delete-ref node) - (unlink-node node)) - (combination - (let ((kind (combination-kind node)) - (info (combination-fun-info node))) - (when (and (eq kind :known) (fun-info-p info)) - (let ((attr (fun-info-attributes info))) - (when (and (not (ir1-attributep attr call)) - ;; ### For now, don't delete potentially - ;; flushable calls when they have the CALL - ;; attribute. Someday we should look at the - ;; functional args to determine if they have - ;; any side effects. + (ref + (delete-ref node) + (unlink-node node)) + (combination + (let ((kind (combination-kind node)) + (info (combination-fun-info node))) + (when (and (eq kind :known) (fun-info-p info)) + (let ((attr (fun-info-attributes info))) + (when (and (not (ir1-attributep attr call)) + ;; ### For now, don't delete potentially + ;; flushable calls when they have the CALL + ;; attribute. Someday we should look at the + ;; functional args to determine if they have + ;; any side effects. (if (policy node (= safety 3)) (ir1-attributep attr flushable) (ir1-attributep attr unsafely-flushable))) (flush-combination node)))))) - (mv-combination - (when (eq (basic-combination-kind node) :local) - (let ((fun (combination-lambda node))) - (when (dolist (var (lambda-vars fun) t) - (when (or (leaf-refs var) - (lambda-var-sets var)) - (return nil))) - (flush-dest (first (basic-combination-args node))) - (delete-let fun))))) - (exit - (let ((value (exit-value node))) - (when value - (flush-dest value) - (setf (exit-value node) nil)))) - (cset - (let ((var (set-var node))) - (when (and (lambda-var-p var) - (null (leaf-refs var))) - (flush-dest (set-value node)) - (setf (basic-var-sets var) - (delq node (basic-var-sets var))) - (unlink-node node)))) + (mv-combination + (when (eq (basic-combination-kind node) :local) + (let ((fun (combination-lambda node))) + (when (dolist (var (lambda-vars fun) t) + (when (or (leaf-refs var) + (lambda-var-sets var)) + (return nil))) + (flush-dest (first (basic-combination-args node))) + (delete-let fun))))) + (exit + (let ((value (exit-value node))) + (when value + (flush-dest value) + (setf (exit-value node) nil)))) + (cset + (let ((var (set-var node))) + (when (and (lambda-var-p var) + (null (leaf-refs var))) + (flush-dest (set-value node)) + (setf (basic-var-sets var) + (delq node (basic-var-sets var))) + (unlink-node node)))) (cast (unless (cast-type-check node) (flush-dest (cast-value node)) @@ -478,7 +478,7 @@ (use-union) ;; ) )) - (setf (return-result-type node) int)))) + (setf (return-result-type node) int)))) nil) ;;; Do stuff to realize that something has changed about the value @@ -526,14 +526,14 @@ (defun ir1-optimize-if (node) (declare (type cif node)) (let ((test (if-test node)) - (block (node-block node))) + (block (node-block node))) (when (and (eq (block-start-node block) node) - (listp (lvar-uses test))) + (listp (lvar-uses test))) (do-uses (use test) - (when (immediately-used-p test use) - (convert-if-if use node) - (when (not (listp (lvar-uses test))) (return))))) + (when (immediately-used-p test use) + (convert-if-if use node) + (when (not (listp (lvar-uses test))) (return))))) (let* ((type (lvar-type test)) (victim @@ -571,16 +571,16 @@ (declare (type node use) (type cif node)) (with-ir1-environment-from-node node (let* ((block (node-block node)) - (test (if-test node)) - (cblock (if-consequent node)) - (ablock (if-alternative node)) - (use-block (node-block use)) - (new-ctran (make-ctran)) - (new-lvar (make-lvar)) - (new-node (make-if :test new-lvar - :consequent cblock - :alternative ablock)) - (new-block (ctran-starts-block new-ctran))) + (test (if-test node)) + (cblock (if-consequent node)) + (ablock (if-alternative node)) + (use-block (node-block use)) + (new-ctran (make-ctran)) + (new-lvar (make-lvar)) + (new-node (make-if :test new-lvar + :consequent cblock + :alternative ablock)) + (new-block (ctran-starts-block new-ctran))) (link-node-to-previous-ctran new-node new-ctran) (setf (lvar-dest new-lvar) new-node) (setf (block-last new-block) new-node) @@ -622,9 +622,9 @@ (defun maybe-delete-exit (node) (declare (type exit node)) (let ((value (exit-value node)) - (entry (exit-entry node))) + (entry (exit-entry node))) (when (and entry - (eq (node-home-lambda node) (node-home-lambda entry))) + (eq (node-home-lambda node) (node-home-lambda entry))) (setf (entry-exits entry) (delq node (entry-exits entry))) (if value (delete-filter node (node-lvar node) value) @@ -644,67 +644,67 @@ (propagate-fun-change node) (maybe-terminate-block node nil)) (let ((args (basic-combination-args node)) - (kind (basic-combination-kind node)) - (info (basic-combination-fun-info node))) + (kind (basic-combination-kind node)) + (info (basic-combination-fun-info node))) (ecase kind (:local (let ((fun (combination-lambda node))) - (if (eq (functional-kind fun) :let) - (propagate-let-args node fun) - (propagate-local-call-args node fun)))) + (if (eq (functional-kind fun) :let) + (propagate-let-args node fun) + (propagate-local-call-args node fun)))) (:error (dolist (arg args) - (when arg - (setf (lvar-reoptimize arg) nil)))) + (when arg + (setf (lvar-reoptimize arg) nil)))) (:full (dolist (arg args) - (when arg - (setf (lvar-reoptimize arg) nil))) + (when arg + (setf (lvar-reoptimize arg) nil))) (when info - (let ((fun (fun-info-derive-type info))) - (when fun - (let ((res (funcall fun node))) - (when res - (derive-node-type node (coerce-to-values res)) - (maybe-terminate-block node nil))))))) + (let ((fun (fun-info-derive-type info))) + (when fun + (let ((res (funcall fun node))) + (when res + (derive-node-type node (coerce-to-values res)) + (maybe-terminate-block node nil))))))) (:known (aver info) (dolist (arg args) - (when arg - (setf (lvar-reoptimize arg) nil))) + (when arg + (setf (lvar-reoptimize arg) nil))) (let ((attr (fun-info-attributes info))) - (when (and (ir1-attributep attr foldable) - ;; KLUDGE: The next test could be made more sensitive, - ;; only suppressing constant-folding of functions with - ;; CALL attributes when they're actually passed - ;; function arguments. -- WHN 19990918 - (not (ir1-attributep attr call)) - (every #'constant-lvar-p args) - (node-lvar node)) - (constant-fold-call node) - (return-from ir1-optimize-combination))) + (when (and (ir1-attributep attr foldable) + ;; KLUDGE: The next test could be made more sensitive, + ;; only suppressing constant-folding of functions with + ;; CALL attributes when they're actually passed + ;; function arguments. -- WHN 19990918 + (not (ir1-attributep attr call)) + (every #'constant-lvar-p args) + (node-lvar node)) + (constant-fold-call node) + (return-from ir1-optimize-combination))) (let ((fun (fun-info-derive-type info))) - (when fun - (let ((res (funcall fun node))) - (when res - (derive-node-type node (coerce-to-values res)) - (maybe-terminate-block node nil))))) + (when fun + (let ((res (funcall fun node))) + (when res + (derive-node-type node (coerce-to-values res)) + (maybe-terminate-block node nil))))) (let ((fun (fun-info-optimizer info))) - (unless (and fun (funcall fun node)) - (dolist (x (fun-info-transforms info)) - #!+sb-show - (when *show-transforms-p* - (let* ((lvar (basic-combination-fun node)) - (fname (lvar-fun-name lvar t))) - (/show "trying transform" x (transform-function x) "for" fname))) - (unless (ir1-transform node x) - #!+sb-show - (when *show-transforms-p* - (/show "quitting because IR1-TRANSFORM result was NIL")) - (return)))))))) + (unless (and fun (funcall fun node)) + (dolist (x (fun-info-transforms info)) + #!+sb-show + (when *show-transforms-p* + (let* ((lvar (basic-combination-fun node)) + (fname (lvar-fun-name lvar t))) + (/show "trying transform" x (transform-function x) "for" fname))) + (unless (ir1-transform node x) + #!+sb-show + (when *show-transforms-p* + (/show "quitting because IR1-TRANSFORM result was NIL")) + (return)))))))) (values)) @@ -726,16 +726,16 @@ (defun maybe-terminate-block (node ir1-converting-not-optimizing-p) (declare (type (or basic-combination cast ref) node)) (let* ((block (node-block node)) - (lvar (node-lvar node)) + (lvar (node-lvar node)) (ctran (node-next node)) - (tail (component-tail (block-component block))) - (succ (first (block-succ block)))) + (tail (component-tail (block-component block))) + (succ (first (block-succ block)))) (declare (ignore lvar)) (unless (or (and (eq node (block-last block)) (eq succ tail)) - (block-delete-p block)) + (block-delete-p block)) (when (eq (node-derived-type node) *empty-type*) - (cond (ir1-converting-not-optimizing-p - (cond + (cond (ir1-converting-not-optimizing-p + (cond ((block-last block) (aver (eq (block-last block) node))) (t @@ -745,8 +745,8 @@ (setf (ctran-block ctran) nil) (setf (node-next node) nil) (link-blocks block (ctran-starts-block ctran))))) - (t - (node-ends-block node))) + (t + (node-ends-block node))) (let ((succ (first (block-succ block)))) (unlink-blocks block succ) @@ -758,7 +758,7 @@ (t (delete-lvar-use node) (when (null (block-pred succ)) (mark-for-deletion succ))))) - t)))) + t)))) ;;; This is called both by IR1 conversion and IR1 optimization when ;;; they have verified the type signature for the call, and are @@ -780,56 +780,56 @@ (defun recognize-known-call (call ir1-converting-not-optimizing-p) (declare (type combination call)) (let* ((ref (lvar-uses (basic-combination-fun call))) - (leaf (when (ref-p ref) (ref-leaf ref))) - (inlinep (if (defined-fun-p leaf) - (defined-fun-inlinep leaf) - :no-chance))) + (leaf (when (ref-p ref) (ref-leaf ref))) + (inlinep (if (defined-fun-p leaf) + (defined-fun-inlinep leaf) + :no-chance))) (cond ((eq inlinep :notinline) (let ((info (info :function :info (leaf-source-name leaf)))) - (when info - (setf (basic-combination-fun-info call) info)) - (values nil nil))) + (when info + (setf (basic-combination-fun-info call) info)) + (values nil nil))) ((not (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function))) + (eq (global-var-kind leaf) :global-function))) (values leaf nil)) ((and (ecase inlinep - (:inline t) - (:no-chance nil) - ((nil :maybe-inline) (policy call (zerop space)))) - (defined-fun-p leaf) - (defined-fun-inline-expansion leaf) - (let ((fun (defined-fun-functional leaf))) - (or (not fun) - (and (eq inlinep :inline) (functional-kind fun)))) - (inline-expansion-ok call)) + (:inline t) + (:no-chance nil) + ((nil :maybe-inline) (policy call (zerop space)))) + (defined-fun-p leaf) + (defined-fun-inline-expansion leaf) + (let ((fun (defined-fun-functional leaf))) + (or (not fun) + (and (eq inlinep :inline) (functional-kind fun)))) + (inline-expansion-ok call)) (flet (;; FIXME: Is this what the old CMU CL internal documentation - ;; called semi-inlining? A more descriptive name would - ;; be nice. -- WHN 2002-01-07 - (frob () - (let ((res (let ((*allow-instrumenting* t)) + ;; called semi-inlining? A more descriptive name would + ;; be nice. -- WHN 2002-01-07 + (frob () + (let ((res (let ((*allow-instrumenting* t)) (ir1-convert-lambda-for-defun (defined-fun-inline-expansion leaf) leaf t #'ir1-convert-inline-lambda)))) - (setf (defined-fun-functional leaf) res) - (change-ref-leaf ref res)))) - (if ir1-converting-not-optimizing-p - (frob) - (with-ir1-environment-from-node call - (frob) - (locall-analyze-component *current-component*)))) + (setf (defined-fun-functional leaf) res) + (change-ref-leaf ref res)))) + (if ir1-converting-not-optimizing-p + (frob) + (with-ir1-environment-from-node call + (frob) + (locall-analyze-component *current-component*)))) (values (ref-leaf (lvar-uses (basic-combination-fun call))) - nil)) + nil)) (t (let ((info (info :function :info (leaf-source-name leaf)))) - (if info - (values leaf - (progn - (setf (basic-combination-kind call) :known) - (setf (basic-combination-fun-info call) info))) - (values leaf nil))))))) + (if info + (values leaf + (progn + (setf (basic-combination-kind call) :known) + (setf (basic-combination-fun-info call) info))) + (values leaf nil))))))) ;;; Check whether CALL satisfies TYPE. If so, apply the type to the ;;; call, and do MAYBE-TERMINATE-BLOCK and return the values of @@ -841,37 +841,37 @@ (defun validate-call-type (call type ir1-converting-not-optimizing-p) (declare (type combination call) (type ctype type)) (cond ((not (fun-type-p type)) - (aver (multiple-value-bind (val win) - (csubtypep type (specifier-type 'function)) - (or val (not win)))) - (recognize-known-call call ir1-converting-not-optimizing-p)) - ((valid-fun-use call type - :argument-test #'always-subtypep - :result-test nil - ;; KLUDGE: Common Lisp is such a dynamic - ;; language that all we can do here in - ;; general is issue a STYLE-WARNING. It - ;; would be nice to issue a full WARNING - ;; in the special case of of type - ;; mismatches within a compilation unit - ;; (as in section 3.2.2.3 of the spec) - ;; but at least as of sbcl-0.6.11, we - ;; don't keep track of whether the - ;; mismatched data came from the same - ;; compilation unit, so we can't do that. - ;; -- WHN 2001-02-11 - ;; - ;; FIXME: Actually, I think we could - ;; issue a full WARNING if the call - ;; violates a DECLAIM FTYPE. - :lossage-fun #'compiler-style-warn - :unwinnage-fun #'compiler-notify) - (assert-call-type call type) - (maybe-terminate-block call ir1-converting-not-optimizing-p) - (recognize-known-call call ir1-converting-not-optimizing-p)) - (t - (setf (combination-kind call) :error) - (values nil nil)))) + (aver (multiple-value-bind (val win) + (csubtypep type (specifier-type 'function)) + (or val (not win)))) + (recognize-known-call call ir1-converting-not-optimizing-p)) + ((valid-fun-use call type + :argument-test #'always-subtypep + :result-test nil + ;; KLUDGE: Common Lisp is such a dynamic + ;; language that all we can do here in + ;; general is issue a STYLE-WARNING. It + ;; would be nice to issue a full WARNING + ;; in the special case of of type + ;; mismatches within a compilation unit + ;; (as in section 3.2.2.3 of the spec) + ;; but at least as of sbcl-0.6.11, we + ;; don't keep track of whether the + ;; mismatched data came from the same + ;; compilation unit, so we can't do that. + ;; -- WHN 2001-02-11 + ;; + ;; FIXME: Actually, I think we could + ;; issue a full WARNING if the call + ;; violates a DECLAIM FTYPE. + :lossage-fun #'compiler-style-warn + :unwinnage-fun #'compiler-notify) + (assert-call-type call type) + (maybe-terminate-block call ir1-converting-not-optimizing-p) + (recognize-known-call call ir1-converting-not-optimizing-p)) + (t + (setf (combination-kind call) :error) + (values nil nil)))) ;;; This is called by IR1-OPTIMIZE when the function for a call has ;;; changed. If the call is local, we try to LET-convert it, and @@ -883,23 +883,23 @@ (defun propagate-fun-change (call) (declare (type combination call)) (let ((*compiler-error-context* call) - (fun-lvar (basic-combination-fun call))) + (fun-lvar (basic-combination-fun call))) (setf (lvar-reoptimize fun-lvar) nil) (case (combination-kind call) (:local (let ((fun (combination-lambda call))) - (maybe-let-convert fun) - (unless (member (functional-kind fun) '(:let :assignment :deleted)) - (derive-node-type call (tail-set-type (lambda-tail-set fun)))))) + (maybe-let-convert fun) + (unless (member (functional-kind fun) '(:let :assignment :deleted)) + (derive-node-type call (tail-set-type (lambda-tail-set fun)))))) (:full (multiple-value-bind (leaf info) - (validate-call-type call (lvar-type fun-lvar) nil) - (cond ((functional-p leaf) - (convert-call-if-possible - (lvar-uses (basic-combination-fun call)) - call)) - ((not leaf)) - ((and (global-var-p leaf) + (validate-call-type call (lvar-type fun-lvar) nil) + (cond ((functional-p leaf) + (convert-call-if-possible + (lvar-uses (basic-combination-fun call)) + call)) + ((not leaf)) + ((and (global-var-p leaf) (eq (global-var-kind leaf) :global-function) (leaf-has-source-name-p leaf) (or (info :function :source-transform (leaf-source-name leaf)) @@ -908,7 +908,7 @@ predicate) (let ((lvar (node-lvar call))) (and lvar (not (if-p (lvar-dest lvar)))))))) - (let ((name (leaf-source-name leaf)) + (let ((name (leaf-source-name leaf)) (dummies (make-gensym-list (length (combination-args call))))) (transform-call call @@ -927,12 +927,12 @@ ;;; replace it, otherwise add a new one. (defun record-optimization-failure (node transform args) (declare (type combination node) (type transform transform) - (type (or fun-type list) args)) + (type (or fun-type list) args)) (let* ((table (component-failed-optimizations *component-being-compiled*)) - (found (assoc transform (gethash node table)))) + (found (assoc transform (gethash node table)))) (if found - (setf (cdr found) args) - (push (cons transform args) (gethash node table)))) + (setf (cdr found) args) + (push (cons transform args) (gethash node table)))) (values)) ;;; Attempt to transform NODE using TRANSFORM-FUNCTION, subject to the @@ -945,50 +945,50 @@ (defun ir1-transform (node transform) (declare (type combination node) (type transform transform)) (let* ((type (transform-type transform)) - (fun (transform-function transform)) - (constrained (fun-type-p type)) - (table (component-failed-optimizations *component-being-compiled*)) - (flame (if (transform-important transform) - (policy node (>= speed inhibit-warnings)) - (policy node (> speed inhibit-warnings)))) - (*compiler-error-context* node)) + (fun (transform-function transform)) + (constrained (fun-type-p type)) + (table (component-failed-optimizations *component-being-compiled*)) + (flame (if (transform-important transform) + (policy node (>= speed inhibit-warnings)) + (policy node (> speed inhibit-warnings)))) + (*compiler-error-context* node)) (cond ((or (not constrained) - (valid-fun-use node type)) - (multiple-value-bind (severity args) - (catch 'give-up-ir1-transform - (transform-call node - (funcall fun node) - (combination-fun-source-name node)) - (values :none nil)) - (ecase severity - (:none - (remhash node table) - nil) - (:aborted - (setf (combination-kind node) :error) - (when args - (apply #'warn args)) - (remhash node table) - nil) - (:failure - (if args - (when flame - (record-optimization-failure node transform args)) - (setf (gethash node table) - (remove transform (gethash node table) :key #'car))) - t) + (valid-fun-use node type)) + (multiple-value-bind (severity args) + (catch 'give-up-ir1-transform + (transform-call node + (funcall fun node) + (combination-fun-source-name node)) + (values :none nil)) + (ecase severity + (:none + (remhash node table) + nil) + (:aborted + (setf (combination-kind node) :error) + (when args + (apply #'warn args)) + (remhash node table) + nil) + (:failure + (if args + (when flame + (record-optimization-failure node transform args)) + (setf (gethash node table) + (remove transform (gethash node table) :key #'car))) + t) (:delayed (remhash node table) nil)))) - ((and flame - (valid-fun-use node - type - :argument-test #'types-equal-or-intersect - :result-test #'values-types-equal-or-intersect)) - (record-optimization-failure node transform type) - t) - (t - t)))) + ((and flame + (valid-fun-use node + type + :argument-test #'types-equal-or-intersect + :result-test #'values-types-equal-or-intersect)) + (record-optimization-failure node transform type) + t) + (t + t)))) ;;; When we don't like an IR1 transform, we throw the severity/reason ;;; and args. @@ -1027,7 +1027,7 @@ (setf *delayed-ir1-transforms* (acons node reasons *delayed-ir1-transforms*)) (throw 'give-up-ir1-transform :delayed)) - ((cdr assoc) + ((cdr assoc) (dolist (reason reasons) (pushnew reason (cdr assoc))) (throw 'give-up-ir1-transform :delayed))))) @@ -1039,19 +1039,19 @@ ;;; to be retried. (defun retry-delayed-ir1-transforms (reason) (setf *delayed-ir1-transforms* - (remove-if-not #'cdr *delayed-ir1-transforms*)) + (remove-if-not #'cdr *delayed-ir1-transforms*)) (let ((reoptimize nil)) (dolist (assoc *delayed-ir1-transforms*) (let ((reasons (remove reason (cdr assoc)))) - (setf (cdr assoc) reasons) - (unless reasons - (let ((node (car assoc))) - (unless (node-deleted node) - (setf reoptimize t) - (setf (node-reoptimize node) t) - (let ((block (node-block node))) - (setf (block-reoptimize block) t) - (reoptimize-component (block-component block) :maybe))))))) + (setf (cdr assoc) reasons) + (unless reasons + (let ((node (car assoc))) + (unless (node-deleted node) + (setf reoptimize t) + (setf (node-reoptimize node) t) + (let ((block (node-block node))) + (setf (block-reoptimize block) t) + (reoptimize-component (block-component block) :maybe))))))) reoptimize)) ;;; Take the lambda-expression RES, IR1 convert it in the proper @@ -1067,18 +1067,18 @@ (defun transform-call (call res source-name) (declare (type combination call) (list res)) (aver (and (legal-fun-name-p source-name) - (not (eql source-name '.anonymous.)))) + (not (eql source-name '.anonymous.)))) (node-ends-block call) (with-ir1-environment-from-node call (with-component-last-block (*current-component* (block-next (node-block call))) (let ((new-fun (ir1-convert-inline-lambda - res - :debug-name (debug-name 'lambda-inlined source-name))) - (ref (lvar-use (combination-fun call)))) - (change-ref-leaf ref new-fun) - (setf (combination-kind call) :full) - (locall-analyze-component *current-component*)))) + res + :debug-name (debug-name 'lambda-inlined source-name))) + (ref (lvar-use (combination-fun call)))) + (change-ref-leaf ref new-fun) + (setf (combination-kind call) :full) + (locall-analyze-component *current-component*)))) (values)) ;;; Replace a call to a foldable function of constant arguments with @@ -1090,52 +1090,52 @@ ;;; VALUES form. (defun constant-fold-call (call) (let ((args (mapcar #'lvar-value (combination-args call))) - (fun-name (combination-fun-source-name call))) + (fun-name (combination-fun-source-name call))) (multiple-value-bind (values win) - (careful-call fun-name - args - call - ;; Note: CMU CL had COMPILER-WARN here, and that - ;; seems more natural, but it's probably not. - ;; - ;; It's especially not while bug 173 exists: - ;; Expressions like - ;; (COND (END - ;; (UNLESS (OR UNSAFE? (<= END SIZE))) - ;; ...)) - ;; can cause constant-folding TYPE-ERRORs (in - ;; #'<=) when END can be proved to be NIL, even - ;; though the code is perfectly legal and safe - ;; because a NIL value of END means that the - ;; #'<= will never be executed. - ;; - ;; Moreover, even without bug 173, - ;; quite-possibly-valid code like - ;; (COND ((NONINLINED-PREDICATE END) - ;; (UNLESS (<= END SIZE)) - ;; ...)) - ;; (where NONINLINED-PREDICATE is something the - ;; compiler can't do at compile time, but which - ;; turns out to make the #'<= expression - ;; unreachable when END=NIL) could cause errors - ;; when the compiler tries to constant-fold (<= - ;; END SIZE). - ;; - ;; So, with or without bug 173, it'd be - ;; unnecessarily evil to do a full - ;; COMPILER-WARNING (and thus return FAILURE-P=T - ;; from COMPILE-FILE) for legal code, so we we - ;; use a wimpier COMPILE-STYLE-WARNING instead. - #-sb-xc-host #'compiler-style-warn - ;; On the other hand, for code we control, we - ;; should be able to work around any bug - ;; 173-related problems, and in particular we - ;; want to be alerted to calls to our own - ;; functions which aren't being folded away; a - ;; COMPILER-WARNING is butch enough to stop the - ;; SBCL build itself in its tracks. - #+sb-xc-host #'compiler-warn - "constant folding") + (careful-call fun-name + args + call + ;; Note: CMU CL had COMPILER-WARN here, and that + ;; seems more natural, but it's probably not. + ;; + ;; It's especially not while bug 173 exists: + ;; Expressions like + ;; (COND (END + ;; (UNLESS (OR UNSAFE? (<= END SIZE))) + ;; ...)) + ;; can cause constant-folding TYPE-ERRORs (in + ;; #'<=) when END can be proved to be NIL, even + ;; though the code is perfectly legal and safe + ;; because a NIL value of END means that the + ;; #'<= will never be executed. + ;; + ;; Moreover, even without bug 173, + ;; quite-possibly-valid code like + ;; (COND ((NONINLINED-PREDICATE END) + ;; (UNLESS (<= END SIZE)) + ;; ...)) + ;; (where NONINLINED-PREDICATE is something the + ;; compiler can't do at compile time, but which + ;; turns out to make the #'<= expression + ;; unreachable when END=NIL) could cause errors + ;; when the compiler tries to constant-fold (<= + ;; END SIZE). + ;; + ;; So, with or without bug 173, it'd be + ;; unnecessarily evil to do a full + ;; COMPILER-WARNING (and thus return FAILURE-P=T + ;; from COMPILE-FILE) for legal code, so we we + ;; use a wimpier COMPILE-STYLE-WARNING instead. + #-sb-xc-host #'compiler-style-warn + ;; On the other hand, for code we control, we + ;; should be able to work around any bug + ;; 173-related problems, and in particular we + ;; want to be alerted to calls to our own + ;; functions which aren't being folded away; a + ;; COMPILER-WARNING is butch enough to stop the + ;; SBCL build itself in its tracks. + #+sb-xc-host #'compiler-warn + "constant folding") (cond ((not win) (setf (combination-kind call) :error)) ((and (proper-list-of-length-p values 1)) @@ -1171,10 +1171,10 @@ (let ((var-type (leaf-type leaf))) (unless (fun-type-p var-type) (let ((int (type-approx-intersection2 var-type type))) - (when (type/= int var-type) - (setf (leaf-type leaf) int) - (dolist (ref (leaf-refs leaf)) - (derive-node-type ref (make-single-value-type int)) + (when (type/= int var-type) + (setf (leaf-type leaf) int) + (dolist (ref (leaf-refs leaf)) + (derive-node-type ref (make-single-value-type int)) ;; KLUDGE: LET var substitution (let* ((lvar (node-lvar ref))) (when (and lvar (combination-p (lvar-dest lvar))) @@ -1193,7 +1193,7 @@ (() (null (rest sets)) :exit-if-null) (set-use (principal-lvar-use (set-value set))) (() (and (combination-p set-use) - (eq (combination-kind set-use) :known) + (eq (combination-kind set-use) :known) (fun-info-p (combination-fun-info set-use)) (not (node-to-be-deleted-p set-use)) (eq (combination-fun-source-name set-use) '+)) @@ -1282,10 +1282,10 @@ (let ((var (set-var node))) (when (and (lambda-var-p var) (leaf-refs var)) (let ((home (lambda-var-home var))) - (when (eq (functional-kind home) :let) - (let* ((initial-value (let-var-initial-value var)) + (when (eq (functional-kind home) :let) + (let* ((initial-value (let-var-initial-value var)) (initial-type (lvar-type initial-value))) - (setf (lvar-reoptimize initial-value) nil) + (setf (lvar-reoptimize initial-value) nil) (propagate-from-sets var initial-type)))))) (derive-node-type node (make-single-value-type @@ -1305,7 +1305,7 @@ (not (eq (defined-fun-inlinep leaf) :notinline))) (global-var (case (global-var-kind leaf) - (:global-function + (:global-function (let ((name (leaf-source-name leaf))) (or #-sb-xc-host (eq (symbol-package (fun-name-block-name name)) @@ -1418,7 +1418,7 @@ (defun propagate-let-args (call fun) (declare (type combination call) (type clambda fun)) (loop for arg in (combination-args call) - and var in (lambda-vars fun) do + and var in (lambda-vars fun) do (when (and arg (lvar-reoptimize arg)) (setf (lvar-reoptimize arg) nil) (cond @@ -1469,31 +1469,31 @@ (declare (type combination call) (type clambda fun)) (unless (or (functional-entry-fun fun) - (lambda-optional-dispatch fun)) + (lambda-optional-dispatch fun)) (let* ((vars (lambda-vars fun)) - (union (mapcar (lambda (arg var) - (when (and arg - (lvar-reoptimize arg) - (null (basic-var-sets var))) - (lvar-type arg))) - (basic-combination-args call) - vars)) - (this-ref (lvar-use (basic-combination-fun call)))) + (union (mapcar (lambda (arg var) + (when (and arg + (lvar-reoptimize arg) + (null (basic-var-sets var))) + (lvar-type arg))) + (basic-combination-args call) + vars)) + (this-ref (lvar-use (basic-combination-fun call)))) (dolist (arg (basic-combination-args call)) - (when arg - (setf (lvar-reoptimize arg) nil))) + (when arg + (setf (lvar-reoptimize arg) nil))) (dolist (ref (leaf-refs fun)) - (let ((dest (node-dest ref))) - (unless (or (eq ref this-ref) (not dest)) - (setq union - (mapcar (lambda (this-arg old) - (when old - (setf (lvar-reoptimize this-arg) nil) - (type-union (lvar-type this-arg) old))) - (basic-combination-args dest) - union))))) + (let ((dest (node-dest ref))) + (unless (or (eq ref this-ref) (not dest)) + (setq union + (mapcar (lambda (this-arg old) + (when old + (setf (lvar-reoptimize this-arg) nil) + (type-union (lvar-type this-arg) old))) + (basic-combination-args dest) + union))))) (loop for var in vars and type in union @@ -1520,32 +1520,32 @@ (:local (let ((fun-lvar (basic-combination-fun node))) (when (lvar-reoptimize fun-lvar) - (setf (lvar-reoptimize fun-lvar) nil) - (maybe-let-convert (combination-lambda node)))) + (setf (lvar-reoptimize fun-lvar) nil) + (maybe-let-convert (combination-lambda node)))) (setf (lvar-reoptimize (first (basic-combination-args node))) nil) (when (eq (functional-kind (combination-lambda node)) :mv-let) (unless (convert-mv-bind-to-let node) - (ir1-optimize-mv-bind node)))) + (ir1-optimize-mv-bind node)))) (:full (let* ((fun (basic-combination-fun node)) - (fun-changed (lvar-reoptimize fun)) - (args (basic-combination-args node))) + (fun-changed (lvar-reoptimize fun)) + (args (basic-combination-args node))) (when fun-changed - (setf (lvar-reoptimize fun) nil) - (let ((type (lvar-type fun))) - (when (fun-type-p type) - (derive-node-type node (fun-type-returns type)))) + (setf (lvar-reoptimize fun) nil) + (let ((type (lvar-type fun))) + (when (fun-type-p type) + (derive-node-type node (fun-type-returns type)))) (maybe-terminate-block node nil) - (let ((use (lvar-uses fun))) - (when (and (ref-p use) (functional-p (ref-leaf use))) - (convert-call-if-possible use node) - (when (eq (basic-combination-kind node) :local) - (maybe-let-convert (ref-leaf use)))))) + (let ((use (lvar-uses fun))) + (when (and (ref-p use) (functional-p (ref-leaf use))) + (convert-call-if-possible use node) + (when (eq (basic-combination-kind node) :local) + (maybe-let-convert (ref-leaf use)))))) (unless (or (eq (basic-combination-kind node) :local) - (eq (lvar-fun-name fun) '%throw)) - (ir1-optimize-mv-call node)) + (eq (lvar-fun-name fun) '%throw)) + (ir1-optimize-mv-call node)) (dolist (arg args) - (setf (lvar-reoptimize arg) nil)))) + (setf (lvar-reoptimize arg) nil)))) (:error)) (values)) @@ -1594,65 +1594,65 @@ ;;; multiple warnings when there is an argument count error. (defun ir1-optimize-mv-call (node) (let ((fun (basic-combination-fun node)) - (*compiler-error-context* node) - (ref (lvar-uses (basic-combination-fun node))) - (args (basic-combination-args node))) + (*compiler-error-context* node) + (ref (lvar-uses (basic-combination-fun node))) + (args (basic-combination-args node))) (unless (and (ref-p ref) (constant-reference-p ref) - (singleton-p args)) + (singleton-p args)) (return-from ir1-optimize-mv-call)) (multiple-value-bind (min max) - (fun-type-nargs (lvar-type fun)) + (fun-type-nargs (lvar-type fun)) (let ((total-nvals - (multiple-value-bind (types nvals) - (values-types (lvar-derived-type (first args))) - (declare (ignore types)) - (if (eq nvals :unknown) nil nvals)))) - - (when total-nvals - (when (and min (< total-nvals min)) - (compiler-warn - "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ + (multiple-value-bind (types nvals) + (values-types (lvar-derived-type (first args))) + (declare (ignore types)) + (if (eq nvals :unknown) nil nvals)))) + + (when total-nvals + (when (and min (< total-nvals min)) + (compiler-warn + "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ at least ~R." - total-nvals min) - (setf (basic-combination-kind node) :error) - (return-from ir1-optimize-mv-call)) - (when (and max (> total-nvals max)) - (compiler-warn - "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ + total-nvals min) + (setf (basic-combination-kind node) :error) + (return-from ir1-optimize-mv-call)) + (when (and max (> total-nvals max)) + (compiler-warn + "MULTIPLE-VALUE-CALL with ~R values when the function expects ~ at most ~R." - total-nvals max) - (setf (basic-combination-kind node) :error) - (return-from ir1-optimize-mv-call))) - - (let ((count (cond (total-nvals) - ((and (policy node (zerop verify-arg-count)) - (eql min max)) - min) - (t nil)))) - (when count - (with-ir1-environment-from-node node - (let* ((dums (make-gensym-list count)) - (ignore (gensym)) - (fun (ir1-convert-lambda - `(lambda (&optional ,@dums &rest ,ignore) - (declare (ignore ,ignore)) - (funcall ,(ref-leaf ref) ,@dums))))) - (change-ref-leaf ref fun) - (aver (eq (basic-combination-kind node) :full)) - (locall-analyze-component *current-component*) - (aver (eq (basic-combination-kind node) :local))))))))) + total-nvals max) + (setf (basic-combination-kind node) :error) + (return-from ir1-optimize-mv-call))) + + (let ((count (cond (total-nvals) + ((and (policy node (zerop verify-arg-count)) + (eql min max)) + min) + (t nil)))) + (when count + (with-ir1-environment-from-node node + (let* ((dums (make-gensym-list count)) + (ignore (gensym)) + (fun (ir1-convert-lambda + `(lambda (&optional ,@dums &rest ,ignore) + (declare (ignore ,ignore)) + (funcall ,(ref-leaf ref) ,@dums))))) + (change-ref-leaf ref fun) + (aver (eq (basic-combination-kind node) :full)) + (locall-analyze-component *current-component*) + (aver (eq (basic-combination-kind node) :local))))))))) (values)) ;;; If we see: ;;; (multiple-value-bind -;;; (x y) -;;; (values xx yy) +;;; (x y) +;;; (values xx yy) ;;; ...) ;;; Convert to: ;;; (let ((x xx) -;;; (y yy)) +;;; (y yy)) ;;; ...) ;;; ;;; What we actually do is convert the VALUES combination into a @@ -1662,46 +1662,46 @@ (defun convert-mv-bind-to-let (call) (declare (type mv-combination call)) (let* ((arg (first (basic-combination-args call))) - (use (lvar-uses arg))) + (use (lvar-uses arg))) (when (and (combination-p use) - (eq (lvar-fun-name (combination-fun use)) - 'values)) + (eq (lvar-fun-name (combination-fun use)) + 'values)) (let* ((fun (combination-lambda call)) - (vars (lambda-vars fun)) - (vals (combination-args use)) - (nvars (length vars)) - (nvals (length vals))) - (cond ((> nvals nvars) - (mapc #'flush-dest (subseq vals nvars)) - (setq vals (subseq vals 0 nvars))) - ((< nvals nvars) - (with-ir1-environment-from-node use - (let ((node-prev (node-prev use))) - (setf (node-prev use) nil) - (setf (ctran-next node-prev) nil) - (collect ((res vals)) - (loop for count below (- nvars nvals) - for prev = node-prev then ctran + (vars (lambda-vars fun)) + (vals (combination-args use)) + (nvars (length vars)) + (nvals (length vals))) + (cond ((> nvals nvars) + (mapc #'flush-dest (subseq vals nvars)) + (setq vals (subseq vals 0 nvars))) + ((< nvals nvars) + (with-ir1-environment-from-node use + (let ((node-prev (node-prev use))) + (setf (node-prev use) nil) + (setf (ctran-next node-prev) nil) + (collect ((res vals)) + (loop for count below (- nvars nvals) + for prev = node-prev then ctran for ctran = (make-ctran) and lvar = (make-lvar use) - do (reference-constant prev ctran lvar nil) - (res lvar) + do (reference-constant prev ctran lvar nil) + (res lvar) finally (link-node-to-previous-ctran use ctran)) - (setq vals (res))))))) - (setf (combination-args use) vals) - (flush-dest (combination-fun use)) - (let ((fun-lvar (basic-combination-fun call))) - (setf (lvar-dest fun-lvar) use) + (setq vals (res))))))) + (setf (combination-args use) vals) + (flush-dest (combination-fun use)) + (let ((fun-lvar (basic-combination-fun call))) + (setf (lvar-dest fun-lvar) use) (setf (combination-fun use) fun-lvar) - (flush-lvar-externally-checkable-type fun-lvar)) - (setf (combination-kind use) :local) - (setf (functional-kind fun) :let) - (flush-dest (first (basic-combination-args call))) - (unlink-node call) - (when vals - (reoptimize-lvar (first vals))) - (propagate-to-args use fun) + (flush-lvar-externally-checkable-type fun-lvar)) + (setf (combination-kind use) :local) + (setf (functional-kind fun) :let) + (flush-dest (first (basic-combination-args call))) + (unlink-node call) + (when vals + (reoptimize-lvar (first vals))) + (propagate-to-args use fun) (reoptimize-call use)) t))) @@ -1720,20 +1720,20 @@ (defoptimizer (values-list optimizer) ((list) node) (let ((use (lvar-uses list))) (when (and (combination-p use) - (eq (lvar-fun-name (combination-fun use)) - 'list)) + (eq (lvar-fun-name (combination-fun use)) + 'list)) ;; FIXME: VALUES might not satisfy an assertion on NODE-LVAR. (change-ref-leaf (lvar-uses (combination-fun node)) - (find-free-fun 'values "in a strange place")) + (find-free-fun 'values "in a strange place")) (setf (combination-kind node) :full) (let ((args (combination-args use))) - (dolist (arg args) - (setf (lvar-dest arg) node) + (dolist (arg args) + (setf (lvar-dest arg) node) (flush-lvar-externally-checkable-type arg)) - (setf (combination-args use) nil) - (flush-dest list) - (setf (combination-args node) args)) + (setf (combination-args use) nil) + (flush-dest list) + (setf (combination-args node) args)) t))) ;;; If VALUES appears in a non-MV context, then effectively convert it @@ -1748,9 +1748,9 @@ (principal-lvar-single-valuify (node-lvar node)) (if vals (let ((dummies (make-gensym-list (length (cdr vals))))) - `(lambda (val ,@dummies) - (declare (ignore ,@dummies)) - val)) + `(lambda (val ,@dummies) + (declare (ignore ,@dummies)) + val)) nil)) ;;; TODO: diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index b297eb4..12a6580 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -33,10 +33,10 @@ ;;; this end, we convert source forms to strings so that source forms ;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR. (defstruct (compiler-error-context - #-no-ansi-print-object - (:print-object (lambda (x stream) - (print-unreadable-object (x stream :type t)))) - (:copier nil)) + #-no-ansi-print-object + (:print-object (lambda (x stream) + (print-unreadable-object (x stream :type t)))) + (:copier nil)) ;; a list of the stringified CARs of the enclosing non-original source forms ;; exceeding the *enclosing-source-cutoff* (enclosing-source nil :type list) @@ -87,8 +87,8 @@ list of subforms suitable for a \"~{~S ~}\" format string." (let ((n-whole (gensym))) `(setf (gethash ',name *source-context-methods*) - (lambda (,n-whole) - (destructuring-bind ,lambda-list ,n-whole ,@body))))) + (lambda (,n-whole) + (destructuring-bind ,lambda-list ,n-whole ,@body))))) (defmacro def-source-context (&rest rest) (deprecation-warning 'def-source-context 'define-source-context) @@ -97,8 +97,8 @@ (define-source-context defstruct (name-or-options &rest slots) (declare (ignore slots)) `(defstruct ,(if (consp name-or-options) - (car name-or-options) - name-or-options))) + (car name-or-options) + name-or-options))) (define-source-context function (thing) (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing))) @@ -109,17 +109,17 @@ ;;; CAR of the second form if appropriate. (defun source-form-context (form) (cond ((atom form) nil) - ((>= (length form) 2) + ((>= (length form) 2) (let* ((context-fun-default (lambda (x) - (declare (ignore x)) - (list (first form) (second form)))) - (context-fun (gethash (first form) - *source-context-methods* - context-fun-default))) + (declare (ignore x)) + (list (first form) (second form)))) + (context-fun (gethash (first form) + *source-context-methods* + context-fun-default))) (declare (type function context-fun)) (funcall context-fun (rest form)))) - (t - form))) + (t + form))) ;;; Given a source path, return the original source form and a ;;; description of the interesting aspects of the context in which it @@ -137,31 +137,31 @@ (defun find-original-source (path) (declare (list path)) (let* ((rpath (reverse (source-path-original-source path))) - (tlf (first rpath)) - (root (find-source-root tlf *source-info*))) + (tlf (first rpath)) + (root (find-source-root tlf *source-info*))) (collect ((context)) (let ((form root) - (current (rest rpath))) - (loop - (when (atom form) - (aver (null current)) - (return)) - (let ((head (first form))) - (when (symbolp head) - (let ((name (symbol-name head))) - (when (and (>= (length name) 3) (string= name "DEF" :end1 3)) - (context (source-form-context form)))))) - (when (null current) (return)) - (setq form (nth (pop current) form))) - - (cond ((context) - (values form (context))) - ((and path root) - (let ((c (source-form-context root))) - (values form (if c (list c) nil)))) - (t - (values '(unable to locate source) - '((some strange place))))))))) + (current (rest rpath))) + (loop + (when (atom form) + (aver (null current)) + (return)) + (let ((head (first form))) + (when (symbolp head) + (let ((name (symbol-name head))) + (when (and (>= (length name) 3) (string= name "DEF" :end1 3)) + (context (source-form-context form)))))) + (when (null current) (return)) + (setq form (nth (pop current) form))) + + (cond ((context) + (values form (context))) + ((and path root) + (let ((c (source-form-context root))) + (values form (if c (list c) nil)))) + (t + (values '(unable to locate source) + '((some strange place))))))))) ;;; Convert a source form to a string, suitably formatted for use in ;;; compiler warnings. @@ -181,46 +181,46 @@ (defun find-error-context (args) (let ((context *compiler-error-context*)) (if (compiler-error-context-p context) - context - (let ((path (or (and (boundp '*current-path*) *current-path*) - (if context - (node-source-path context) - nil)))) - (when (and *source-info* path) - (multiple-value-bind (form src-context) (find-original-source path) - (collect ((full nil cons) - (short nil cons)) - (let ((forms (source-path-forms path)) - (n 0)) - (dolist (src (if (member (first forms) args) - (rest forms) - forms)) - (if (>= n *enclosing-source-cutoff*) - (short (stringify-form (if (consp src) - (car src) - src) - nil)) - (full (stringify-form src))) - (incf n))) - - (let* ((tlf (source-path-tlf-number path)) - (file-info (source-info-file-info *source-info*))) - (make-compiler-error-context - :enclosing-source (short) - :source (full) - :original-source (stringify-form form) - :context src-context - :file-name (file-info-name file-info) - :file-position - (multiple-value-bind (ignore pos) - (find-source-root tlf *source-info*) - (declare (ignore ignore)) - pos) - :original-source-path - (source-path-original-source path) - :lexenv (if context - (node-lexenv context) - (if (boundp '*lexenv*) *lexenv* nil))))))))))) + context + (let ((path (or (and (boundp '*current-path*) *current-path*) + (if context + (node-source-path context) + nil)))) + (when (and *source-info* path) + (multiple-value-bind (form src-context) (find-original-source path) + (collect ((full nil cons) + (short nil cons)) + (let ((forms (source-path-forms path)) + (n 0)) + (dolist (src (if (member (first forms) args) + (rest forms) + forms)) + (if (>= n *enclosing-source-cutoff*) + (short (stringify-form (if (consp src) + (car src) + src) + nil)) + (full (stringify-form src))) + (incf n))) + + (let* ((tlf (source-path-tlf-number path)) + (file-info (source-info-file-info *source-info*))) + (make-compiler-error-context + :enclosing-source (short) + :source (full) + :original-source (stringify-form form) + :context src-context + :file-name (file-info-name file-info) + :file-position + (multiple-value-bind (ignore pos) + (find-source-root tlf *source-info*) + (declare (ignore ignore)) + pos) + :original-source-path + (source-path-original-source path) + :lexenv (if context + (node-lexenv context) + (if (boundp '*lexenv*) *lexenv* nil))))))))))) ;;;; printing error messages @@ -247,11 +247,11 @@ ;;; count when we are done. (defun note-message-repeats (stream &optional (terpri t)) (cond ((= *last-message-count* 1) - (when terpri - (terpri stream))) - ((> *last-message-count* 1) - (format stream "~&; [Last message occurs ~W times.]~2%" - *last-message-count*))) + (when terpri + (terpri stream))) + ((> *last-message-count* 1) + (format stream "~&; [Last message occurs ~W times.]~2%" + *last-message-count*))) (setq *last-message-count* 0)) ;;; Print out the message, with appropriate context if we can find it. @@ -268,70 +268,70 @@ (defun %print-compiler-message (stream format-string format-args) (declare (type simple-string format-string)) - (declare (type list format-args)) + (declare (type list format-args)) (let ((context (find-error-context format-args))) (cond (context - (let ((file (compiler-error-context-file-name context)) - (in (compiler-error-context-context context)) - (form (compiler-error-context-original-source context)) - (enclosing (compiler-error-context-enclosing-source context)) - (source (compiler-error-context-source context)) - (last *last-error-context*)) - - (unless (and last - (equal file (compiler-error-context-file-name last))) - (when (pathnamep file) - (note-message-repeats stream) - (setq last nil) - (format stream "~2&; file: ~A~%" (namestring file)))) - - (unless (and last - (equal in (compiler-error-context-context last))) - (note-message-repeats stream) - (setq last nil) - (pprint-logical-block (stream nil :per-line-prefix "; ") - (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in)) - (terpri stream)) - - (unless (and last - (string= form - (compiler-error-context-original-source last))) - (note-message-repeats stream) - (setq last nil) - (pprint-logical-block (stream nil :per-line-prefix "; ") - (format stream " ~A" form)) - (fresh-line stream)) - - (unless (and last - (equal enclosing - (compiler-error-context-enclosing-source last))) - (when enclosing - (note-message-repeats stream) - (setq last nil) - (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing))) - - (unless (and last - (equal source (compiler-error-context-source last))) - (setq *last-format-string* nil) - (when source - (note-message-repeats stream) - (dolist (src source) - (fresh-line stream) - (write-string "; ==>" stream) - (terpri stream) - (pprint-logical-block (stream nil :per-line-prefix "; ") - (write-string src stream))))))) - (t - (fresh-line stream) - (note-message-repeats stream) - (setq *last-format-string* nil))) - + (let ((file (compiler-error-context-file-name context)) + (in (compiler-error-context-context context)) + (form (compiler-error-context-original-source context)) + (enclosing (compiler-error-context-enclosing-source context)) + (source (compiler-error-context-source context)) + (last *last-error-context*)) + + (unless (and last + (equal file (compiler-error-context-file-name last))) + (when (pathnamep file) + (note-message-repeats stream) + (setq last nil) + (format stream "~2&; file: ~A~%" (namestring file)))) + + (unless (and last + (equal in (compiler-error-context-context last))) + (note-message-repeats stream) + (setq last nil) + (pprint-logical-block (stream nil :per-line-prefix "; ") + (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in)) + (terpri stream)) + + (unless (and last + (string= form + (compiler-error-context-original-source last))) + (note-message-repeats stream) + (setq last nil) + (pprint-logical-block (stream nil :per-line-prefix "; ") + (format stream " ~A" form)) + (fresh-line stream)) + + (unless (and last + (equal enclosing + (compiler-error-context-enclosing-source last))) + (when enclosing + (note-message-repeats stream) + (setq last nil) + (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing))) + + (unless (and last + (equal source (compiler-error-context-source last))) + (setq *last-format-string* nil) + (when source + (note-message-repeats stream) + (dolist (src source) + (fresh-line stream) + (write-string "; ==>" stream) + (terpri stream) + (pprint-logical-block (stream nil :per-line-prefix "; ") + (write-string src stream))))))) + (t + (fresh-line stream) + (note-message-repeats stream) + (setq *last-format-string* nil))) + (setq *last-error-context* context)) ;; FIXME: this testing for effective equality of compiler messages ;; is ugly, and really ought to be done at a higher level. (unless (and (equal format-string *last-format-string*) - (tree-equal format-args *last-format-args*)) + (tree-equal format-args *last-format-args*)) (note-message-repeats stream nil) (setq *last-format-string* format-string) (setq *last-format-args* format-args) @@ -339,20 +339,20 @@ (pprint-logical-block (stream nil :per-line-prefix "; ") (format stream "~&~?" format-string format-args)) (fresh-line stream)) - + (incf *last-message-count*) (values)) (defun print-compiler-condition (condition) (declare (type condition condition)) (let (;; These different classes of conditions have different - ;; effects on the return codes of COMPILE-FILE, so it's nice - ;; for users to be able to pick them out by lexical search - ;; through the output. - (what (etypecase condition - (style-warning 'style-warning) - (warning 'warning) - ((or error compiler-error) 'error)))) + ;; effects on the return codes of COMPILE-FILE, so it's nice + ;; for users to be able to pick them out by lexical search + ;; through the output. + (what (etypecase condition + (style-warning 'style-warning) + (warning 'warning) + ((or error compiler-error) 'error)))) (print-compiler-message *error-output* (format nil "caught ~S:~%~~@< ~~@;~~A~~:>" what) @@ -377,43 +377,43 @@ a STYLE-WARNING (or any more serious condition).")) has written, having proved that it is unreachable.")) (macrolet ((with-condition ((condition datum args) &body body) - (with-unique-names (block) - `(block ,block - (let ((,condition - (coerce-to-condition ,datum ,args - 'simple-compiler-note - 'with-condition))) - (restart-case - (signal ,condition) - (muffle-warning () - (return-from ,block (values)))) - ,@body - (values)))))) + (with-unique-names (block) + `(block ,block + (let ((,condition + (coerce-to-condition ,datum ,args + 'simple-compiler-note + 'with-condition))) + (restart-case + (signal ,condition) + (muffle-warning () + (return-from ,block (values)))) + ,@body + (values)))))) (defun compiler-notify (datum &rest args) (unless (if *compiler-error-context* - (policy *compiler-error-context* (= inhibit-warnings 3)) - (policy *lexenv* (= inhibit-warnings 3))) + (policy *compiler-error-context* (= inhibit-warnings 3)) + (policy *lexenv* (= inhibit-warnings 3))) (with-condition (condition datum args) - (incf *compiler-note-count*) - (print-compiler-message - *error-output* - (format nil "note: ~~A") - (list (princ-to-string condition))))) + (incf *compiler-note-count*) + (print-compiler-message + *error-output* + (format nil "note: ~~A") + (list (princ-to-string condition))))) (values)) ;; Issue a note when we might or might not be in the compiler. (defun maybe-compiler-notify (&rest rest) (if (boundp '*lexenv*) ; if we're in the compiler - (apply #'compiler-notify rest) - (with-condition (condition (car rest) (cdr rest)) - (let ((stream *error-output*)) - (pprint-logical-block (stream nil :per-line-prefix ";") - (format stream " note: ~3I~_") - (pprint-logical-block (stream nil) - (format stream "~A" condition))) - ;; (outside logical block, no per-line-prefix) - (fresh-line stream)))))) + (apply #'compiler-notify rest) + (with-condition (condition (car rest) (cdr rest)) + (let ((stream *error-output*)) + (pprint-logical-block (stream nil :per-line-prefix ";") + (format stream " note: ~3I~_") + (pprint-logical-block (stream nil) + (format stream "~A" condition))) + ;; (outside logical block, no per-line-prefix) + (fresh-line stream)))))) ;;; The politically correct way to print out progress messages and ;;; such like. We clear the current error context so that we know that @@ -436,12 +436,12 @@ has written, having proved that it is unreachable.")) (let ((ep (first (block-succ (component-head component))))) (aver ep) ; else no entry points?? (multiple-value-bind (form context) - (find-original-source - (node-source-path (block-start-node ep))) + (find-original-source + (node-source-path (block-start-node ep))) (declare (ignore form)) (let ((*print-level* 2) - (*print-pretty* nil)) - (format nil "~{~{~S~^ ~}~^ => ~}" context))))) + (*print-pretty* nil)) + (format nil "~{~{~S~^ ~}~^ => ~}" context))))) ;;;; condition system interface @@ -463,14 +463,14 @@ has written, having proved that it is unreachable.")) (signal condition) (incf *compiler-error-count*) (setf *warnings-p* t - *failure-p* t) + *failure-p* t) (print-compiler-condition condition) (continue condition)) (defun compiler-warning-handler (condition) (signal condition) (incf *compiler-warning-count*) (setf *warnings-p* t - *failure-p* t) + *failure-p* t) (print-compiler-condition condition) (muffle-warning condition)) (defun compiler-style-warning-handler (condition) @@ -499,40 +499,40 @@ has written, having proved that it is unreachable.")) ;;; the compiler, hence the BOUNDP check. (defun note-undefined-reference (name kind) (unless (and - ;; Check for boundness so we don't blow up if we're called - ;; when IR1 conversion isn't going on. - (boundp '*lexenv*) - (or - ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below - ;; isn't a good idea; we should have INHIBIT-WARNINGS - ;; affect compiler notes, not STYLE-WARNINGs. And I'm not - ;; sure what the BOUNDP '*LEXENV* test above is for; it's - ;; likely a good idea, but it probably deserves an - ;; explanatory comment. - (policy *lexenv* (= inhibit-warnings 3)) - ;; KLUDGE: weird decoupling between here and where we're - ;; going to signal the condition. I don't think we can - ;; rewrite this using SIGNAL and RESTART-CASE (to take - ;; advantage of the (SATISFIES HANDLE-CONDITION-P) - ;; handler, because if that doesn't handle it the ordinary - ;; compiler handlers will trigger. - (typep - (ecase kind - (:variable (make-condition 'warning)) - ((:function :type) (make-condition 'style-warning))) - (car - (rassoc 'muffle-warning - (lexenv-handled-conditions *lexenv*)))))) + ;; Check for boundness so we don't blow up if we're called + ;; when IR1 conversion isn't going on. + (boundp '*lexenv*) + (or + ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below + ;; isn't a good idea; we should have INHIBIT-WARNINGS + ;; affect compiler notes, not STYLE-WARNINGs. And I'm not + ;; sure what the BOUNDP '*LEXENV* test above is for; it's + ;; likely a good idea, but it probably deserves an + ;; explanatory comment. + (policy *lexenv* (= inhibit-warnings 3)) + ;; KLUDGE: weird decoupling between here and where we're + ;; going to signal the condition. I don't think we can + ;; rewrite this using SIGNAL and RESTART-CASE (to take + ;; advantage of the (SATISFIES HANDLE-CONDITION-P) + ;; handler, because if that doesn't handle it the ordinary + ;; compiler handlers will trigger. + (typep + (ecase kind + (:variable (make-condition 'warning)) + ((:function :type) (make-condition 'style-warning))) + (car + (rassoc 'muffle-warning + (lexenv-handled-conditions *lexenv*)))))) (let* ((found (dolist (warning *undefined-warnings* nil) - (when (and (equal (undefined-warning-name warning) name) - (eq (undefined-warning-kind warning) kind)) - (return warning)))) - (res (or found - (make-undefined-warning :name name :kind kind)))) + (when (and (equal (undefined-warning-name warning) name) + (eq (undefined-warning-kind warning) kind)) + (return warning)))) + (res (or found + (make-undefined-warning :name name :kind kind)))) (unless found (push res *undefined-warnings*)) (when (or (not *undefined-warning-limit*) - (< (undefined-warning-count res) *undefined-warning-limit*)) - (push (find-error-context (list name)) - (undefined-warning-warnings res))) + (< (undefined-warning-count res) *undefined-warning-limit*)) + (push (find-error-context (list name)) + (undefined-warning-warnings res))) (incf (undefined-warning-count res)))) (values)) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 862f8ae..81d98c6 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -31,35 +31,35 @@ (compiler-error "The lambda variable ~S is not a symbol." name)) (when (member name names-so-far :test #'eq) (compiler-error "The variable ~S occurs more than once in the lambda list." - name)) + name)) (let ((kind (info :variable :kind name))) (when (or (keywordp name) (eq kind :constant)) (compiler-error "The name of the lambda variable ~S is already in use to name a constant." - name)) + name)) (cond ((eq kind :special) - (let ((specvar (find-free-var name))) - (make-lambda-var :%source-name name - :type (leaf-type specvar) - :where-from (leaf-where-from specvar) - :specvar specvar))) - (t - (make-lambda-var :%source-name name))))) + (let ((specvar (find-free-var name))) + (make-lambda-var :%source-name name + :type (leaf-type specvar) + :where-from (leaf-where-from specvar) + :specvar specvar))) + (t + (make-lambda-var :%source-name name))))) ;;; Make the default keyword for a &KEY arg, checking that the keyword ;;; isn't already used by one of the VARS. (declaim (ftype (sfunction (symbol list t) symbol) make-keyword-for-arg)) (defun make-keyword-for-arg (symbol vars keywordify) (let ((key (if (and keywordify (not (keywordp symbol))) - (keywordicate symbol) - symbol))) + (keywordicate symbol) + symbol))) (dolist (var vars) (let ((info (lambda-var-arg-info var))) - (when (and info - (eq (arg-info-kind info) :keyword) - (eq (arg-info-key info) key)) - (compiler-error - "The keyword ~S appears more than once in the lambda list." - key)))) + (when (and info + (eq (arg-info-kind info) :keyword) + (eq (arg-info-key info) key)) + (compiler-error + "The keyword ~S appears more than once in the lambda list." + key)))) key)) ;;; Parse a lambda list into a list of VAR structures, stripping off @@ -75,124 +75,124 @@ ;;; 4. a list of the &AUX variables; and ;;; 5. a list of the &AUX values. (declaim (ftype (sfunction (list) (values list boolean boolean list list)) - make-lambda-vars)) + make-lambda-vars)) (defun make-lambda-vars (list) (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux - morep more-context more-count) + morep more-context more-count) (parse-lambda-list list) (declare (ignore auxp)) ; since we just iterate over AUX regardless (collect ((vars) - (names-so-far) - (aux-vars) - (aux-vals)) + (names-so-far) + (aux-vars) + (aux-vals)) (flet (;; PARSE-DEFAULT deals with defaults and supplied-p args - ;; for optionals and keywords args. - (parse-default (spec info) - (when (consp (cdr spec)) - (setf (arg-info-default info) (second spec)) - (when (consp (cddr spec)) - (let* ((supplied-p (third spec)) - (supplied-var (varify-lambda-arg supplied-p - (names-so-far)))) - (setf (arg-info-supplied-p info) supplied-var) - (names-so-far supplied-p) - (when (> (length (the list spec)) 3) - (compiler-error - "The list ~S is too long to be an arg specifier." - spec))))))) - - (dolist (name required) - (let ((var (varify-lambda-arg name (names-so-far)))) - (vars var) - (names-so-far name))) - - (dolist (spec optional) - (if (atom spec) - (let ((var (varify-lambda-arg spec (names-so-far)))) - (setf (lambda-var-arg-info var) - (make-arg-info :kind :optional)) - (vars var) - (names-so-far spec)) - (let* ((name (first spec)) - (var (varify-lambda-arg name (names-so-far))) - (info (make-arg-info :kind :optional))) - (setf (lambda-var-arg-info var) info) - (vars var) - (names-so-far name) - (parse-default spec info)))) - - (when restp - (let ((var (varify-lambda-arg rest (names-so-far)))) - (setf (lambda-var-arg-info var) (make-arg-info :kind :rest)) - (vars var) - (names-so-far rest))) - - (when morep - (let ((var (varify-lambda-arg more-context (names-so-far)))) - (setf (lambda-var-arg-info var) - (make-arg-info :kind :more-context)) - (vars var) - (names-so-far more-context)) - (let ((var (varify-lambda-arg more-count (names-so-far)))) - (setf (lambda-var-arg-info var) - (make-arg-info :kind :more-count)) - (vars var) - (names-so-far more-count))) - - (dolist (spec keys) - (cond - ((atom spec) - (let ((var (varify-lambda-arg spec (names-so-far)))) - (setf (lambda-var-arg-info var) - (make-arg-info :kind :keyword - :key (make-keyword-for-arg spec - (vars) - t))) - (vars var) - (names-so-far spec))) - ((atom (first spec)) - (let* ((name (first spec)) - (var (varify-lambda-arg name (names-so-far))) - (info (make-arg-info - :kind :keyword - :key (make-keyword-for-arg name (vars) t)))) - (setf (lambda-var-arg-info var) info) - (vars var) - (names-so-far name) - (parse-default spec info))) - (t - (let ((head (first spec))) - (unless (proper-list-of-length-p head 2) - (error "malformed &KEY argument specifier: ~S" spec)) - (let* ((name (second head)) - (var (varify-lambda-arg name (names-so-far))) - (info (make-arg-info - :kind :keyword - :key (make-keyword-for-arg (first head) - (vars) - nil)))) - (setf (lambda-var-arg-info var) info) - (vars var) - (names-so-far name) - (parse-default spec info)))))) - - (dolist (spec aux) - (cond ((atom spec) - (let ((var (varify-lambda-arg spec nil))) - (aux-vars var) - (aux-vals nil) - (names-so-far spec))) - (t - (unless (proper-list-of-length-p spec 1 2) - (compiler-error "malformed &AUX binding specifier: ~S" - spec)) - (let* ((name (first spec)) - (var (varify-lambda-arg name nil))) - (aux-vars var) - (aux-vals (second spec)) - (names-so-far name))))) - - (values (vars) keyp allowp (aux-vars) (aux-vals)))))) + ;; for optionals and keywords args. + (parse-default (spec info) + (when (consp (cdr spec)) + (setf (arg-info-default info) (second spec)) + (when (consp (cddr spec)) + (let* ((supplied-p (third spec)) + (supplied-var (varify-lambda-arg supplied-p + (names-so-far)))) + (setf (arg-info-supplied-p info) supplied-var) + (names-so-far supplied-p) + (when (> (length (the list spec)) 3) + (compiler-error + "The list ~S is too long to be an arg specifier." + spec))))))) + + (dolist (name required) + (let ((var (varify-lambda-arg name (names-so-far)))) + (vars var) + (names-so-far name))) + + (dolist (spec optional) + (if (atom spec) + (let ((var (varify-lambda-arg spec (names-so-far)))) + (setf (lambda-var-arg-info var) + (make-arg-info :kind :optional)) + (vars var) + (names-so-far spec)) + (let* ((name (first spec)) + (var (varify-lambda-arg name (names-so-far))) + (info (make-arg-info :kind :optional))) + (setf (lambda-var-arg-info var) info) + (vars var) + (names-so-far name) + (parse-default spec info)))) + + (when restp + (let ((var (varify-lambda-arg rest (names-so-far)))) + (setf (lambda-var-arg-info var) (make-arg-info :kind :rest)) + (vars var) + (names-so-far rest))) + + (when morep + (let ((var (varify-lambda-arg more-context (names-so-far)))) + (setf (lambda-var-arg-info var) + (make-arg-info :kind :more-context)) + (vars var) + (names-so-far more-context)) + (let ((var (varify-lambda-arg more-count (names-so-far)))) + (setf (lambda-var-arg-info var) + (make-arg-info :kind :more-count)) + (vars var) + (names-so-far more-count))) + + (dolist (spec keys) + (cond + ((atom spec) + (let ((var (varify-lambda-arg spec (names-so-far)))) + (setf (lambda-var-arg-info var) + (make-arg-info :kind :keyword + :key (make-keyword-for-arg spec + (vars) + t))) + (vars var) + (names-so-far spec))) + ((atom (first spec)) + (let* ((name (first spec)) + (var (varify-lambda-arg name (names-so-far))) + (info (make-arg-info + :kind :keyword + :key (make-keyword-for-arg name (vars) t)))) + (setf (lambda-var-arg-info var) info) + (vars var) + (names-so-far name) + (parse-default spec info))) + (t + (let ((head (first spec))) + (unless (proper-list-of-length-p head 2) + (error "malformed &KEY argument specifier: ~S" spec)) + (let* ((name (second head)) + (var (varify-lambda-arg name (names-so-far))) + (info (make-arg-info + :kind :keyword + :key (make-keyword-for-arg (first head) + (vars) + nil)))) + (setf (lambda-var-arg-info var) info) + (vars var) + (names-so-far name) + (parse-default spec info)))))) + + (dolist (spec aux) + (cond ((atom spec) + (let ((var (varify-lambda-arg spec nil))) + (aux-vars var) + (aux-vals nil) + (names-so-far spec))) + (t + (unless (proper-list-of-length-p spec 1 2) + (compiler-error "malformed &AUX binding specifier: ~S" + spec)) + (let* ((name (first spec)) + (var (varify-lambda-arg name nil))) + (aux-vars var) + (aux-vals (second spec)) + (names-so-far name))))) + + (values (vars) keyp allowp (aux-vars) (aux-vals)))))) ;;; This is similar to IR1-CONVERT-PROGN-BODY except that we ;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before @@ -203,25 +203,25 @@ ;;; SOURCE-NAME and DEBUG-NAME. But I (WHN) don't use &AUX bindings, ;;; so I'm not motivated. Patches will be accepted... (defun ir1-convert-aux-bindings (start next result body aux-vars aux-vals - post-binding-lexenv) + post-binding-lexenv) (declare (type ctran start next) (type (or lvar null) result) (list body aux-vars aux-vals)) (if (null aux-vars) (let ((*lexenv* (make-lexenv :vars (copy-list post-binding-lexenv)))) - (ir1-convert-progn-body start next result body)) + (ir1-convert-progn-body start next result body)) (let ((ctran (make-ctran)) (fun-lvar (make-lvar)) - (fun (ir1-convert-lambda-body body - (list (first aux-vars)) - :aux-vars (rest aux-vars) - :aux-vals (rest aux-vals) - :post-binding-lexenv post-binding-lexenv - :debug-name (debug-name - '&aux-bindings + (fun (ir1-convert-lambda-body body + (list (first aux-vars)) + :aux-vars (rest aux-vars) + :aux-vals (rest aux-vals) + :post-binding-lexenv post-binding-lexenv + :debug-name (debug-name + '&aux-bindings aux-vars)))) - (reference-leaf start ctran fun-lvar fun) - (ir1-convert-combination-args fun-lvar ctran next result - (list (first aux-vals))))) + (reference-leaf start ctran fun-lvar fun) + (ir1-convert-combination-args fun-lvar ctran next result + (list (first aux-vals))))) (values)) ;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind @@ -238,26 +238,26 @@ (defun ir1-convert-special-bindings (start next result body aux-vars aux-vals svars post-binding-lexenv) (declare (type ctran start next) (type (or lvar null) result) - (list body aux-vars aux-vals svars)) + (list body aux-vars aux-vals svars)) (cond ((null svars) (ir1-convert-aux-bindings start next result body aux-vars aux-vals - post-binding-lexenv)) + post-binding-lexenv)) (t (ctran-starts-block next) (let ((cleanup (make-cleanup :kind :special-bind)) - (var (first svars)) - (bind-ctran (make-ctran)) - (cleanup-ctran (make-ctran))) + (var (first svars)) + (bind-ctran (make-ctran)) + (cleanup-ctran (make-ctran))) (ir1-convert start bind-ctran nil - `(%special-bind ',(lambda-var-specvar var) ,var)) + `(%special-bind ',(lambda-var-specvar var) ,var)) (setf (cleanup-mess-up cleanup) (ctran-use bind-ctran)) (let ((*lexenv* (make-lexenv :cleanup cleanup))) - (ir1-convert bind-ctran cleanup-ctran nil '(%cleanup-point)) - (ir1-convert-special-bindings cleanup-ctran next result + (ir1-convert bind-ctran cleanup-ctran nil '(%cleanup-point)) + (ir1-convert-special-bindings cleanup-ctran next result body aux-vars aux-vals - (rest svars) - post-binding-lexenv))))) + (rest svars) + post-binding-lexenv))))) (values)) ;;; Create a lambda node out of some code, returning the result. The @@ -278,25 +278,25 @@ ;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated ;;; to get the initial value for the corresponding AUX-VAR. (defun ir1-convert-lambda-body (body - vars - &key - aux-vars - aux-vals - (source-name '.anonymous.) - debug-name + vars + &key + aux-vars + aux-vals + (source-name '.anonymous.) + debug-name (note-lexical-bindings t) - post-binding-lexenv) + post-binding-lexenv) (declare (list body vars aux-vars aux-vals)) ;; We're about to try to put new blocks into *CURRENT-COMPONENT*. (aver-live-component *current-component*) (let* ((bind (make-bind)) - (lambda (make-lambda :vars vars + (lambda (make-lambda :vars vars :bind bind :%source-name source-name :%debug-name debug-name)) - (result-ctran (make-ctran)) + (result-ctran (make-ctran)) (result-lvar (make-lvar))) (awhen (lexenv-lambda *lexenv*) @@ -316,27 +316,27 @@ (new-venv nil cons)) (dolist (var vars) - ;; As far as I can see, LAMBDA-VAR-HOME should never have - ;; been set before. Let's make sure. -- WHN 2001-09-29 - (aver (not (lambda-var-home var))) - (setf (lambda-var-home var) lambda) - (let ((specvar (lambda-var-specvar var))) - (cond (specvar - (svars var) - (new-venv (cons (leaf-source-name specvar) specvar))) - (t + ;; As far as I can see, LAMBDA-VAR-HOME should never have + ;; been set before. Let's make sure. -- WHN 2001-09-29 + (aver (not (lambda-var-home var))) + (setf (lambda-var-home var) lambda) + (let ((specvar (lambda-var-specvar var))) + (cond (specvar + (svars var) + (new-venv (cons (leaf-source-name specvar) specvar))) + (t (when note-lexical-bindings (note-lexical-binding (leaf-source-name var))) - (new-venv (cons (leaf-source-name var) var)))))) + (new-venv (cons (leaf-source-name var) var)))))) (let ((*lexenv* (make-lexenv :vars (new-venv) - :lambda lambda - :cleanup nil))) - (setf (bind-lambda bind) lambda) - (setf (node-lexenv bind) *lexenv*) + :lambda lambda + :cleanup nil))) + (setf (bind-lambda bind) lambda) + (setf (node-lexenv bind) *lexenv*) - (let ((block (ctran-starts-block result-ctran))) - (let ((return (make-return :result result-lvar :lambda lambda)) + (let ((block (ctran-starts-block result-ctran))) + (let ((return (make-return :result result-lvar :lambda lambda)) (tail-set (make-tail-set :funs (list lambda)))) (setf (lambda-tail-set lambda) tail-set) (setf (lambda-return lambda) return) @@ -352,10 +352,10 @@ (ctran-starts-block prebind-ctran) (link-node-to-previous-ctran bind prebind-ctran) (use-ctran bind postbind-ctran) - (ir1-convert-special-bindings postbind-ctran result-ctran + (ir1-convert-special-bindings postbind-ctran result-ctran result-lvar body aux-vars aux-vals (svars) - post-binding-lexenv))))) + post-binding-lexenv))))) (link-blocks (component-head *current-component*) (node-block bind)) (push lambda (component-new-functionals *current-component*)) @@ -383,14 +383,14 @@ (defun convert-optional-entry (fun vars vals defaults name) (declare (type clambda fun) (list vars vals defaults)) (let* ((fvars (reverse vars)) - (arg-vars (mapcar (lambda (var) - (make-lambda-var - :%source-name (leaf-source-name var) - :type (leaf-type var) - :where-from (leaf-where-from var) - :specvar (lambda-var-specvar var))) - fvars)) - (fun (collect ((default-bindings) + (arg-vars (mapcar (lambda (var) + (make-lambda-var + :%source-name (leaf-source-name var) + :type (leaf-type var) + :where-from (leaf-where-from var) + :specvar (lambda-var-specvar var))) + fvars)) + (fun (collect ((default-bindings) (default-vals)) (dolist (default defaults) (if (constantp default) @@ -407,14 +407,14 @@ ;; share these names instead ;; of consing up several ;; identical ones. Oh well. - :debug-name (debug-name - '&optional-processor + :debug-name (debug-name + '&optional-processor name) :note-lexical-bindings nil)))) (mapc (lambda (var arg-var) - (when (cdr (leaf-refs arg-var)) - (setf (leaf-ever-used var) t))) - fvars arg-vars) + (when (cdr (leaf-refs arg-var)) + (setf (leaf-ever-used var) t))) + fvars arg-vars) fun)) ;;; This function deals with supplied-p vars in optional arguments. If @@ -430,33 +430,33 @@ source-name debug-name force post-binding-lexenv) (declare (type optional-dispatch res) - (list default-vars default-vals entry-vars entry-vals vars body - aux-vars aux-vals)) + (list default-vars default-vals entry-vars entry-vals vars body + aux-vars aux-vals)) (let* ((arg (first vars)) - (arg-name (leaf-source-name arg)) - (info (lambda-var-arg-info arg)) - (default (arg-info-default info)) + (arg-name (leaf-source-name arg)) + (info (lambda-var-arg-info arg)) + (default (arg-info-default info)) (supplied-p (arg-info-supplied-p info)) (force (or force (not (sb!xc:constantp (arg-info-default info))))) - (ep (if supplied-p - (ir1-convert-hairy-args - res - (list* supplied-p arg default-vars) - (list* (leaf-source-name supplied-p) arg-name default-vals) - (cons arg entry-vars) - (list* t arg-name entry-vals) - (rest vars) t body aux-vars aux-vals - source-name debug-name + (ep (if supplied-p + (ir1-convert-hairy-args + res + (list* supplied-p arg default-vars) + (list* (leaf-source-name supplied-p) arg-name default-vals) + (cons arg entry-vars) + (list* t arg-name entry-vals) + (rest vars) t body aux-vars aux-vals + source-name debug-name force post-binding-lexenv) - (ir1-convert-hairy-args - res - (cons arg default-vars) - (cons arg-name default-vals) - (cons arg entry-vars) - (cons arg-name entry-vals) - (rest vars) supplied-p-p body aux-vars aux-vals - source-name debug-name + (ir1-convert-hairy-args + res + (cons arg default-vars) + (cons arg-name default-vals) + (cons arg entry-vars) + (cons arg-name entry-vals) + (rest vars) supplied-p-p body aux-vars aux-vals + source-name debug-name force post-binding-lexenv)))) ;; We want to delay converting the entry, but there exist @@ -507,51 +507,51 @@ (defun convert-more-entry (res entry-vars entry-vals rest morep keys name) (declare (type optional-dispatch res) (list entry-vars entry-vals keys)) (collect ((arg-vars) - (arg-vals (reverse entry-vals)) - (temps) - (body)) + (arg-vals (reverse entry-vals)) + (temps) + (body)) (dolist (var (reverse entry-vars)) (arg-vars (make-lambda-var :%source-name (leaf-source-name var) - :type (leaf-type var) - :where-from (leaf-where-from var)))) + :type (leaf-type var) + :where-from (leaf-where-from var)))) (let* ((*allow-instrumenting* nil) (n-context (gensym "N-CONTEXT-")) - (context-temp (make-lambda-var :%source-name n-context)) - (n-count (gensym "N-COUNT-")) - (count-temp (make-lambda-var :%source-name n-count - :type (specifier-type 'index)))) + (context-temp (make-lambda-var :%source-name n-context)) + (n-count (gensym "N-COUNT-")) + (count-temp (make-lambda-var :%source-name n-count + :type (specifier-type 'index)))) (arg-vars context-temp count-temp) (when rest - (arg-vals `(%listify-rest-args - ,n-context ,n-count))) + (arg-vals `(%listify-rest-args + ,n-context ,n-count))) (when morep - (arg-vals n-context) - (arg-vals n-count)) + (arg-vals n-context) + (arg-vals n-count)) (when (optional-dispatch-keyp res) - (let ((n-index (gensym "N-INDEX-")) - (n-key (gensym "N-KEY-")) - (n-value-temp (gensym "N-VALUE-TEMP-")) - (n-allowp (gensym "N-ALLOWP-")) - (n-losep (gensym "N-LOSEP-")) - (allowp (or (optional-dispatch-allowp res) - (policy *lexenv* (zerop safety)))) + (let ((n-index (gensym "N-INDEX-")) + (n-key (gensym "N-KEY-")) + (n-value-temp (gensym "N-VALUE-TEMP-")) + (n-allowp (gensym "N-ALLOWP-")) + (n-losep (gensym "N-LOSEP-")) + (allowp (or (optional-dispatch-allowp res) + (policy *lexenv* (zerop safety)))) (found-allow-p nil)) - (temps `(,n-index (1- ,n-count)) n-key n-value-temp) - (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp))) + (temps `(,n-index (1- ,n-count)) n-key n-value-temp) + (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp))) - (collect ((tests)) - (dolist (key keys) - (let* ((info (lambda-var-arg-info key)) - (default (arg-info-default info)) - (keyword (arg-info-key info)) - (supplied-p (arg-info-supplied-p info)) - (n-value (gensym "N-VALUE-")) + (collect ((tests)) + (dolist (key keys) + (let* ((info (lambda-var-arg-info key)) + (default (arg-info-default info)) + (keyword (arg-info-key info)) + (supplied-p (arg-info-supplied-p info)) + (n-value (gensym "N-VALUE-")) (clause (cond (supplied-p (let ((n-supplied (gensym "N-SUPPLIED-"))) (temps n-supplied) @@ -563,50 +563,50 @@ (arg-vals n-value) `((eq ,n-key ',keyword) (setq ,n-value ,n-value-temp)))))) - (when (and (not allowp) (eq keyword :allow-other-keys)) + (when (and (not allowp) (eq keyword :allow-other-keys)) (setq found-allow-p t) (setq clause - (append clause `((setq ,n-allowp ,n-value-temp))))) + (append clause `((setq ,n-allowp ,n-value-temp))))) (temps `(,n-value ,default)) - (tests clause))) + (tests clause))) - (unless allowp - (temps n-allowp n-losep) + (unless allowp + (temps n-allowp n-losep) (unless found-allow-p (tests `((eq ,n-key :allow-other-keys) (setq ,n-allowp ,n-value-temp)))) - (tests `(t - (setq ,n-losep (list ,n-key))))) - - (body - `(when (oddp ,n-count) - (%odd-key-args-error))) - - (body - `(locally - (declare (optimize (safety 0))) - (loop - (when (minusp ,n-index) (return)) - (setf ,n-value-temp (%more-arg ,n-context ,n-index)) - (decf ,n-index) - (setq ,n-key (%more-arg ,n-context ,n-index)) - (decf ,n-index) - (cond ,@(tests))))) - - (unless allowp - (body `(when (and ,n-losep (not ,n-allowp)) - (%unknown-key-arg-error (car ,n-losep)))))))) + (tests `(t + (setq ,n-losep (list ,n-key))))) + + (body + `(when (oddp ,n-count) + (%odd-key-args-error))) + + (body + `(locally + (declare (optimize (safety 0))) + (loop + (when (minusp ,n-index) (return)) + (setf ,n-value-temp (%more-arg ,n-context ,n-index)) + (decf ,n-index) + (setq ,n-key (%more-arg ,n-context ,n-index)) + (decf ,n-index) + (cond ,@(tests))))) + + (unless allowp + (body `(when (and ,n-losep (not ,n-allowp)) + (%unknown-key-arg-error (car ,n-losep)))))))) (let ((ep (ir1-convert-lambda-body - `((let ,(temps) - ,@(body) - (%funcall ,(optional-dispatch-main-entry res) - ,@(arg-vals)))) - (arg-vars) - :debug-name (debug-name '&more-processor name) + `((let ,(temps) + ,@(body) + (%funcall ,(optional-dispatch-main-entry res) + ,@(arg-vals)))) + (arg-vars) + :debug-name (debug-name '&more-processor name) :note-lexical-bindings nil))) - (setf (optional-dispatch-more-entry res) + (setf (optional-dispatch-more-entry res) (register-entry-point ep res))))) (values)) @@ -629,16 +629,16 @@ ;;; incoming value is NIL, so we must union NULL with the declared ;;; type when computing the type for the main entry's argument. (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals - rest more-context more-count keys supplied-p-p - body aux-vars aux-vals - source-name debug-name post-binding-lexenv) + rest more-context more-count keys supplied-p-p + body aux-vars aux-vals + source-name debug-name post-binding-lexenv) (declare (type optional-dispatch res) - (list default-vars default-vals entry-vars entry-vals keys body - aux-vars aux-vals)) + (list default-vars default-vals entry-vars entry-vals keys body + aux-vars aux-vals)) (collect ((main-vars (reverse default-vars)) - (main-vals default-vals cons) - (bind-vars) - (bind-vals)) + (main-vals default-vals cons) + (bind-vars) + (bind-vals)) (when rest (main-vars rest) (main-vals '())) @@ -650,51 +650,51 @@ (dolist (key keys) (let* ((info (lambda-var-arg-info key)) - (default (arg-info-default info)) - (hairy-default (not (sb!xc:constantp default))) - (supplied-p (arg-info-supplied-p info)) - (n-val (make-symbol (format nil - "~A-DEFAULTING-TEMP" - (leaf-source-name key)))) - (key-type (leaf-type key)) - (val-temp (make-lambda-var - :%source-name n-val - :type (if hairy-default - (type-union key-type (specifier-type 'null)) - key-type)))) - (main-vars val-temp) - (bind-vars key) - (cond ((or hairy-default supplied-p) - (let* ((n-supplied (gensym "N-SUPPLIED-")) - (supplied-temp (make-lambda-var - :%source-name n-supplied))) - (unless supplied-p - (setf (arg-info-supplied-p info) supplied-temp)) - (when hairy-default - (setf (arg-info-default info) nil)) - (main-vars supplied-temp) - (cond (hairy-default - (main-vals nil nil) - (bind-vals `(if ,n-supplied ,n-val ,default))) - (t - (main-vals default nil) - (bind-vals n-val))) - (when supplied-p - (bind-vars supplied-p) - (bind-vals n-supplied)))) - (t - (main-vals (arg-info-default info)) - (bind-vals n-val))))) + (default (arg-info-default info)) + (hairy-default (not (sb!xc:constantp default))) + (supplied-p (arg-info-supplied-p info)) + (n-val (make-symbol (format nil + "~A-DEFAULTING-TEMP" + (leaf-source-name key)))) + (key-type (leaf-type key)) + (val-temp (make-lambda-var + :%source-name n-val + :type (if hairy-default + (type-union key-type (specifier-type 'null)) + key-type)))) + (main-vars val-temp) + (bind-vars key) + (cond ((or hairy-default supplied-p) + (let* ((n-supplied (gensym "N-SUPPLIED-")) + (supplied-temp (make-lambda-var + :%source-name n-supplied))) + (unless supplied-p + (setf (arg-info-supplied-p info) supplied-temp)) + (when hairy-default + (setf (arg-info-default info) nil)) + (main-vars supplied-temp) + (cond (hairy-default + (main-vals nil nil) + (bind-vals `(if ,n-supplied ,n-val ,default))) + (t + (main-vals default nil) + (bind-vals n-val))) + (when supplied-p + (bind-vars supplied-p) + (bind-vals n-supplied)))) + (t + (main-vals (arg-info-default info)) + (bind-vals n-val))))) (let* ((name (or debug-name source-name)) (main-entry (ir1-convert-lambda-body - body (main-vars) - :aux-vars (append (bind-vars) aux-vars) - :aux-vals (append (bind-vals) aux-vals) - :post-binding-lexenv post-binding-lexenv - :debug-name (debug-name 'varargs-entry name))) - (last-entry (convert-optional-entry main-entry default-vars - (main-vals) () name))) + body (main-vars) + :aux-vars (append (bind-vars) aux-vars) + :aux-vals (append (bind-vals) aux-vals) + :post-binding-lexenv post-binding-lexenv + :debug-name (debug-name 'varargs-entry name))) + (last-entry (convert-optional-entry main-entry default-vars + (main-vals) () name))) (setf (optional-dispatch-main-entry res) (register-entry-point main-entry res)) (convert-more-entry res entry-vars entry-vals rest more-context keys @@ -702,11 +702,11 @@ (push (register-entry-point (if supplied-p-p - (convert-optional-entry last-entry entry-vars entry-vals + (convert-optional-entry last-entry entry-vars entry-vals () name) - last-entry) + last-entry) res) - (optional-dispatch-entry-points res)) + (optional-dispatch-entry-points res)) last-entry))) ;;; This function generates the entry point functions for the @@ -757,14 +757,14 @@ entry-vars entry-vals nil nil nil vars supplied-p-p body aux-vars aux-vals source-name debug-name - post-binding-lexenv) + post-binding-lexenv) (let* ((name (or debug-name source-name)) (fun (ir1-convert-lambda-body - body (reverse default-vars) - :aux-vars aux-vars - :aux-vals aux-vals - :post-binding-lexenv post-binding-lexenv - :debug-name (debug-name 'hairy-arg-processor name)))) + body (reverse default-vars) + :aux-vars aux-vars + :aux-vals aux-vals + :post-binding-lexenv post-binding-lexenv + :debug-name (debug-name 'hairy-arg-processor name)))) (setf (optional-dispatch-main-entry res) fun) (register-entry-point fun res) @@ -782,7 +782,7 @@ (nvals (cons (leaf-source-name arg) default-vals))) (ir1-convert-hairy-args res nvars nvals nvars nvals (rest vars) nil body aux-vars aux-vals - source-name debug-name + source-name debug-name nil post-binding-lexenv))) (t (let* ((arg (first vars)) @@ -794,13 +794,13 @@ res default-vars default-vals entry-vars entry-vals vars supplied-p-p body aux-vars aux-vals - source-name debug-name + source-name debug-name force post-binding-lexenv))) ;; See GENERATE-OPTIONAL-DEFAULT-ENTRY. (push (if (lambda-p ep) (register-entry-point (if supplied-p-p - (convert-optional-entry + (convert-optional-entry ep entry-vars entry-vals nil (or debug-name source-name)) ep) @@ -814,49 +814,49 @@ entry-vars entry-vals arg nil nil (rest vars) supplied-p-p body aux-vars aux-vals - source-name debug-name - post-binding-lexenv)) + source-name debug-name + post-binding-lexenv)) (:more-context (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil arg (second vars) (cddr vars) supplied-p-p body aux-vars aux-vals - source-name debug-name - post-binding-lexenv)) + source-name debug-name + post-binding-lexenv)) (:keyword (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil nil nil vars supplied-p-p body aux-vars aux-vals source-name debug-name - post-binding-lexenv))))))) + post-binding-lexenv))))))) ;;; This function deals with the case where we have to make an ;;; OPTIONAL-DISPATCH to represent a LAMBDA. We cons up the result and ;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we ;;; figure out the MIN-ARGS and MAX-ARGS. (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals - &key - post-binding-lexenv - (source-name '.anonymous.) - (debug-name + &key + post-binding-lexenv + (source-name '.anonymous.) + (debug-name (debug-name '&optional-dispatch vars))) (declare (list body vars aux-vars aux-vals)) (let ((res (make-optional-dispatch :arglist vars - :allowp allowp - :keyp keyp - :%source-name source-name - :%debug-name debug-name + :allowp allowp + :keyp keyp + :%source-name source-name + :%debug-name debug-name :plist `(:ir1-environment (,*lexenv* ,*current-path*)))) - (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) + (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) (aver-live-component *current-component*) (push res (component-new-functionals *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals - source-name debug-name nil post-binding-lexenv) + source-name debug-name nil post-binding-lexenv) (setf (optional-dispatch-min-args res) min) (setf (optional-dispatch-max-args res) - (+ (1- (length (optional-dispatch-entry-points res))) min)) + (+ (1- (length (optional-dispatch-entry-points res))) min)) res)) @@ -865,13 +865,13 @@ debug-name) (unless (consp form) (compiler-error "A ~S was found when expecting a lambda expression:~% ~S" - (type-of form) - form)) + (type-of form) + form)) (unless (eq (car form) 'lambda) (compiler-error "~S was expected but ~S was found:~% ~S" - 'lambda - (car form) - form)) + 'lambda + (car form) + form)) (unless (and (consp (cdr form)) (listp (cadr form))) (compiler-error "The lambda expression has a missing or non-list lambda list:~% ~S" @@ -882,10 +882,10 @@ (multiple-value-bind (forms decls) (parse-body (cddr form)) (binding* (((*lexenv* result-type post-binding-lexenv) (process-decls decls (append aux-vars vars) nil - :binding-form-p t)) + :binding-form-p t)) (forms (if (and *allow-instrumenting* (policy *lexenv* (>= insert-debug-catch 2))) - `((catch (locally + `((catch (locally (declare (optimize (insert-step-conditions 0))) (make-symbol "SB-DEBUG-CATCH-TAG")) ,@forms)) @@ -897,13 +897,13 @@ (ir1-convert-hairy-lambda forms vars keyp allow-other-keys aux-vars aux-vals - :post-binding-lexenv post-binding-lexenv + :post-binding-lexenv post-binding-lexenv :source-name source-name :debug-name debug-name) (ir1-convert-lambda-body forms vars :aux-vars aux-vars :aux-vals aux-vals - :post-binding-lexenv post-binding-lexenv + :post-binding-lexenv post-binding-lexenv :source-name source-name :debug-name debug-name)))) (setf (functional-inline-expansion res) form) @@ -913,13 +913,13 @@ ;;; helper for LAMBDA-like things, to massage them into a form ;;; suitable for IR1-CONVERT-LAMBDA. (defun ir1-convert-lambdalike (thing - &key + &key (source-name '.anonymous.) - debug-name) + debug-name) (ecase (car thing) - ((lambda) - (ir1-convert-lambda thing - :source-name source-name + ((lambda) + (ir1-convert-lambda thing + :source-name source-name :debug-name debug-name)) ((instance-lambda) (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) @@ -931,21 +931,21 @@ (let ((name (cadr thing)) (lambda-expression `(lambda ,@(cddr thing)))) (if (legal-fun-name-p name) - (let ((defined-fun-res (get-defined-fun name)) - (res (ir1-convert-lambda lambda-expression + (let ((defined-fun-res (get-defined-fun name)) + (res (ir1-convert-lambda lambda-expression :source-name name))) - (assert-global-function-definition-type name res) + (assert-global-function-definition-type name res) (setf (defined-fun-functional defined-fun-res) res) (unless (eq (defined-fun-inlinep defined-fun-res) :notinline) (substitute-leaf-if (lambda (ref) (policy ref (> recognize-self-calls 0))) res defined-fun-res)) - res) - (ir1-convert-lambda lambda-expression :debug-name name)))) - ((lambda-with-lexenv) - (ir1-convert-inline-lambda thing - :source-name source-name + res) + (ir1-convert-lambda lambda-expression :debug-name name)))) + ((lambda-with-lexenv) + (ir1-convert-inline-lambda thing + :source-name source-name :debug-name debug-name)))) ;;;; defining global functions @@ -955,24 +955,24 @@ ;;; LAMBDA-WITH-LEXENV, so we may have to augment the environment to ;;; reflect the state at the definition site. (defun ir1-convert-inline-lambda (fun &key - (source-name '.anonymous.) - debug-name) + (source-name '.anonymous.) + debug-name) (destructuring-bind (decls macros symbol-macros &rest body) - (if (eq (car fun) 'lambda-with-lexenv) - (cdr fun) - `(() () () . ,(cdr fun))) + (if (eq (car fun) 'lambda-with-lexenv) + (cdr fun) + `(() () () . ,(cdr fun))) (let ((*lexenv* (make-lexenv - :default (process-decls decls nil nil - :lexenv (make-null-lexenv)) - :vars (copy-list symbol-macros) - :funs (mapcar (lambda (x) - `(,(car x) . - (macro . ,(coerce (cdr x) 'function)))) - macros) - :policy (lexenv-policy *lexenv*)))) + :default (process-decls decls nil nil + :lexenv (make-null-lexenv)) + :vars (copy-list symbol-macros) + :funs (mapcar (lambda (x) + `(,(car x) . + (macro . ,(coerce (cdr x) 'function)))) + macros) + :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) - :source-name source-name - :debug-name debug-name)))) + :source-name source-name + :debug-name debug-name)))) ;;; Get a DEFINED-FUN object for a function we are about to define. If ;;; the function has been forward referenced, then substitute for the @@ -982,21 +982,21 @@ (let ((found (find-free-fun name "shouldn't happen! (defined-fun)"))) (note-name-defined name :function) (cond ((not (defined-fun-p found)) - (aver (not (info :function :inlinep name))) - (let* ((where-from (leaf-where-from found)) - (res (make-defined-fun - :%source-name name - :where-from (if (eq where-from :declared) - :declared :defined) - :type (leaf-type found)))) - (substitute-leaf res found) - (setf (gethash name *free-funs*) res))) - ;; If *FREE-FUNS* has a previously converted definition - ;; for this name, then blow it away and try again. - ((defined-fun-functional found) - (remhash name *free-funs*) - (get-defined-fun name)) - (t found)))) + (aver (not (info :function :inlinep name))) + (let* ((where-from (leaf-where-from found)) + (res (make-defined-fun + :%source-name name + :where-from (if (eq where-from :declared) + :declared :defined) + :type (leaf-type found)))) + (substitute-leaf res found) + (setf (gethash name *free-funs*) res))) + ;; If *FREE-FUNS* has a previously converted definition + ;; for this name, then blow it away and try again. + ((defined-fun-functional found) + (remhash name *free-funs*) + (get-defined-fun name)) + (t found)))) ;;; Check a new global function definition for consistency with ;;; previous declaration or definition, and assert argument/result @@ -1006,8 +1006,8 @@ ;;; This avoids redundant checks such as NUMBERP on the args to +, etc. (defun assert-new-definition (var fun) (let ((type (leaf-type var)) - (for-real (eq (leaf-where-from var) :declared)) - (info (info :function :info (leaf-source-name var)))) + (for-real (eq (leaf-where-from var) :declared)) + (info (info :function :info (leaf-source-name var)))) (assert-definition-type fun type ;; KLUDGE: Common Lisp is such a dynamic language that in general @@ -1019,16 +1019,16 @@ ;; compilation unit, so we can't do that. -- WHN 2001-02-11 :lossage-fun #'compiler-style-warn :unwinnage-fun (cond (info #'compiler-style-warn) - (for-real #'compiler-notify) - (t nil)) + (for-real #'compiler-notify) + (t nil)) :really-assert (and for-real - (not (and info - (ir1-attributep (fun-info-attributes info) - explicit-check)))) + (not (and info + (ir1-attributep (fun-info-attributes info) + explicit-check)))) :where (if for-real - "previous declaration" - "previous definition")))) + "previous declaration" + "previous definition")))) ;;; Convert a lambda doing all the basic stuff we would do if we were ;;; converting a DEFUN. In the old CMU CL system, this was used both @@ -1046,24 +1046,24 @@ (unless (eq (defined-fun-inlinep var) :inline) (setf (defined-fun-inline-expansion var) nil)) (let* ((name (leaf-source-name var)) - (fun (funcall converter lambda - :source-name name)) - (fun-info (info :function :info name))) + (fun (funcall converter lambda + :source-name name)) + (fun-info (info :function :info name))) (setf (functional-inlinep fun) (defined-fun-inlinep var)) (assert-new-definition var fun) (setf (defined-fun-inline-expansion var) var-expansion) ;; If definitely not an interpreter stub, then substitute for ;; any old references. (unless (or (eq (defined-fun-inlinep var) :notinline) - (not *block-compile*) - (and fun-info - (or (fun-info-transforms fun-info) - (fun-info-templates fun-info) - (fun-info-ir2-convert fun-info)))) - (substitute-leaf fun var) - ;; If in a simple environment, then we can allow backward - ;; references to this function from following top level forms. - (when expansion (setf (defined-fun-functional var) fun))) + (not *block-compile*) + (and fun-info + (or (fun-info-transforms fun-info) + (fun-info-templates fun-info) + (fun-info-ir2-convert fun-info)))) + (substitute-leaf fun var) + ;; If in a simple environment, then we can allow backward + ;; references to this function from following top level forms. + (when expansion (setf (defined-fun-functional var) fun))) fun))) ;;; the even-at-compile-time part of DEFUN @@ -1074,35 +1074,35 @@ (let ((defined-fun nil)) ; will be set below if we're in the compiler (when compile-toplevel ;; better be in the compiler - (aver (boundp '*lexenv*)) + (aver (boundp '*lexenv*)) (remhash name *free-funs*) (setf defined-fun (get-defined-fun name)) (aver (fasl-output-p *compile-object*)) (if (member name *fun-names-in-this-file* :test #'equal) - (warn 'duplicate-definition :name name) - (push name *fun-names-in-this-file*))) + (warn 'duplicate-definition :name name) + (push name *fun-names-in-this-file*))) (become-defined-fun-name name) - + (cond (lambda-with-lexenv - (setf (info :function :inline-expansion-designator name) - lambda-with-lexenv) - (when defined-fun - (setf (defined-fun-inline-expansion defined-fun) - lambda-with-lexenv))) - (t - (clear-info :function :inline-expansion-designator name))) + (setf (info :function :inline-expansion-designator name) + lambda-with-lexenv) + (when defined-fun + (setf (defined-fun-inline-expansion defined-fun) + lambda-with-lexenv))) + (t + (clear-info :function :inline-expansion-designator name))) ;; old CMU CL comment: ;; If there is a type from a previous definition, blast it, ;; since it is obsolete. (when (and defined-fun - (eq (leaf-where-from defined-fun) :defined)) + (eq (leaf-where-from defined-fun) :defined)) (setf (leaf-type defined-fun) - ;; FIXME: If this is a block compilation thing, shouldn't - ;; we be setting the type to the full derived type for the - ;; definition, instead of this most general function type? - (specifier-type 'function)))) + ;; FIXME: If this is a block compilation thing, shouldn't + ;; we be setting the type to the full derived type for the + ;; definition, instead of this most general function type? + (specifier-type 'function)))) (values)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 2144cbd..6516ca2 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -59,8 +59,8 @@ (let ((fun (lexenv-find name funs :test #'equal))) ;; a declaration will trump a proclamation (if (and fun (defined-fun-p fun)) - (eq (defined-fun-inlinep fun) :notinline) - (eq (info :function :inlinep name) :notinline)))) + (eq (defined-fun-inlinep fun) :notinline) + (eq (info :function :inlinep name) :notinline)))) ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. @@ -70,27 +70,27 @@ (setf (info :function :where-from name) :assumed)) (let ((where (info :function :where-from name))) (when (and (eq where :assumed) - ;; In the ordinary target Lisp, it's silly to report - ;; undefinedness when the function is defined in the - ;; running Lisp. But at cross-compile time, the current - ;; definedness of a function is irrelevant to the - ;; definedness at runtime, which is what matters. - #-sb-xc-host (not (fboundp name))) + ;; In the ordinary target Lisp, it's silly to report + ;; undefinedness when the function is defined in the + ;; running Lisp. But at cross-compile time, the current + ;; definedness of a function is irrelevant to the + ;; definedness at runtime, which is what matters. + #-sb-xc-host (not (fboundp name))) (note-undefined-reference name :function)) (make-global-var :kind :global-function :%source-name name :type (if (or *derive-function-types* - (eq where :declared) - (and (member name *fun-names-in-this-file* :test #'equal) - (not (fun-lexically-notinline-p name)))) - (info :function :type name) - (specifier-type 'function)) + (eq where :declared) + (and (member name *fun-names-in-this-file* :test #'equal) + (not (fun-lexically-notinline-p name)))) + (info :function :type name) + (specifier-type 'function)) :where-from where))) ;;; Has the *FREE-FUNS* entry FREE-FUN become invalid? ;;; -;;; In CMU CL, the answer was implicitly always true, so this +;;; In CMU CL, the answer was implicitly always true, so this ;;; predicate didn't exist. ;;; ;;; This predicate was added to fix bug 138 in SBCL. In some obscure @@ -109,27 +109,27 @@ ;; (sbcl-0.pre7.118) is this one: (and (defined-fun-p free-fun) (let ((functional (defined-fun-functional free-fun))) - (or (and functional - (eql (functional-kind functional) :deleted)) - (and (lambda-p functional) - (or - ;; (The main reason for this first test is to bail - ;; out early in cases where the LAMBDA-COMPONENT - ;; call in the second test would fail because links - ;; it needs are uninitialized or invalid.) - ;; - ;; If the BIND node for this LAMBDA is null, then - ;; according to the slot comments, the LAMBDA has - ;; been deleted or its call has been deleted. In - ;; that case, it seems rather questionable to reuse - ;; it, and certainly it shouldn't be necessary to - ;; reuse it, so we cheerfully declare it invalid. - (null (lambda-bind functional)) - ;; If this IR1 stuff belongs to a dead component, - ;; then we can't reuse it without getting into - ;; bizarre confusion. - (eql (component-info (lambda-component functional)) - :dead))))))) + (or (and functional + (eql (functional-kind functional) :deleted)) + (and (lambda-p functional) + (or + ;; (The main reason for this first test is to bail + ;; out early in cases where the LAMBDA-COMPONENT + ;; call in the second test would fail because links + ;; it needs are uninitialized or invalid.) + ;; + ;; If the BIND node for this LAMBDA is null, then + ;; according to the slot comments, the LAMBDA has + ;; been deleted or its call has been deleted. In + ;; that case, it seems rather questionable to reuse + ;; it, and certainly it shouldn't be necessary to + ;; reuse it, so we cheerfully declare it invalid. + (null (lambda-bind functional)) + ;; If this IR1 stuff belongs to a dead component, + ;; then we can't reuse it without getting into + ;; bizarre confusion. + (eql (component-info (lambda-component functional)) + :dead))))))) ;;; If NAME already has a valid entry in *FREE-FUNS*, then return ;;; the value. Otherwise, make a new GLOBAL-VAR using information from @@ -140,32 +140,32 @@ (declaim (ftype (sfunction (t string) global-var) find-free-fun)) (defun find-free-fun (name context) (or (let ((old-free-fun (gethash name *free-funs*))) - (and (not (invalid-free-fun-p old-free-fun)) - old-free-fun)) + (and (not (invalid-free-fun-p old-free-fun)) + old-free-fun)) (ecase (info :function :kind name) - ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged. - (:macro - (compiler-error "The macro name ~S was found ~A." name context)) - (:special-form - (compiler-error "The special form name ~S was found ~A." - name - context)) - ((:function nil) - (check-fun-name name) - (note-if-setf-fun-and-macro name) - (let ((expansion (fun-name-inline-expansion name)) - (inlinep (info :function :inlinep name))) - (setf (gethash name *free-funs*) - (if (or expansion inlinep) - (make-defined-fun - :%source-name name - :inline-expansion expansion - :inlinep inlinep - :where-from (info :function :where-from name) - :type (if (eq inlinep :notinline) - (specifier-type 'function) - (info :function :type name))) - (find-free-really-fun name)))))))) + ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged. + (:macro + (compiler-error "The macro name ~S was found ~A." name context)) + (:special-form + (compiler-error "The special form name ~S was found ~A." + name + context)) + ((:function nil) + (check-fun-name name) + (note-if-setf-fun-and-macro name) + (let ((expansion (fun-name-inline-expansion name)) + (inlinep (info :function :inlinep name))) + (setf (gethash name *free-funs*) + (if (or expansion inlinep) + (make-defined-fun + :%source-name name + :inline-expansion expansion + :inlinep inlinep + :where-from (info :function :where-from name) + :type (if (eq inlinep :notinline) + (specifier-type 'function) + (info :function :type name))) + (find-free-really-fun name)))))))) ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. @@ -173,12 +173,12 @@ (defun find-lexically-apparent-fun (name context) (let ((var (lexenv-find name funs :test #'equal))) (cond (var - (unless (leaf-p var) - (aver (and (consp var) (eq (car var) 'macro))) - (compiler-error "found macro name ~S ~A" name context)) - var) - (t - (find-free-fun name context))))) + (unless (leaf-p var) + (aver (and (consp var) (eq (car var) 'macro))) + (compiler-error "found macro name ~S ~A" name context)) + var) + (t + (find-free-fun name context))))) ;;; Return the LEAF node for a global variable reference to NAME. If ;;; NAME is already entered in *FREE-VARS*, then we just return the @@ -191,14 +191,14 @@ (compiler-error "Variable name is not a symbol: ~S." name)) (or (gethash name *free-vars*) (let ((kind (info :variable :kind name)) - (type (info :variable :type name)) - (where-from (info :variable :where-from name))) - (when (and (eq where-from :assumed) (eq kind :global)) - (note-undefined-reference name :variable)) - (setf (gethash name *free-vars*) - (case kind - (:alien - (info :variable :alien-info name)) + (type (info :variable :type name)) + (where-from (info :variable :where-from name))) + (when (and (eq where-from :assumed) (eq kind :global)) + (note-undefined-reference name :variable)) + (setf (gethash name *free-vars*) + (case kind + (:alien + (info :variable :alien-info name)) ;; FIXME: The return value in this case should really be ;; of type SB!C::LEAF. I don't feel too badly about it, ;; because the MACRO idiom is scattered throughout this @@ -208,17 +208,17 @@ (let ((expansion (info :variable :macro-expansion name)) (type (type-specifier (info :variable :type name)))) `(macro . (the ,type ,expansion)))) - (:constant - (let ((value (info :variable :constant-value name))) - (make-constant :value value - :%source-name name - :type (ctype-of value) - :where-from where-from))) - (t - (make-global-var :kind kind - :%source-name name - :type type - :where-from where-from))))))) + (:constant + (let ((value (info :variable :constant-value name))) + (make-constant :value value + :%source-name name + :type (ctype-of value) + :where-from where-from))) + (t + (make-global-var :kind kind + :%source-name name + :type type + :where-from where-from))))))) ;;; Grovel over CONSTANT checking for any sub-parts that need to be ;;; processed with MAKE-LOAD-FORM. We have to be careful, because @@ -230,73 +230,73 @@ (def!constant list-to-hash-table-threshold 32)) (defun maybe-emit-make-load-forms (constant) (let ((things-processed nil) - (count 0)) + (count 0)) ;; FIXME: Does this LIST-or-HASH-TABLE messiness give much benefit? (declare (type (or list hash-table) things-processed) - (type (integer 0 #.(1+ list-to-hash-table-threshold)) count) - (inline member)) + (type (integer 0 #.(1+ list-to-hash-table-threshold)) count) + (inline member)) (labels ((grovel (value) - ;; Unless VALUE is an object which which obviously - ;; can't contain other objects - (unless (typep value - '(or #-sb-xc-host unboxed-array - #+sb-xc-host (simple-array (unsigned-byte 8) (*)) - symbol - number - character - string)) - (etypecase things-processed - (list - (when (member value things-processed :test #'eq) - (return-from grovel nil)) - (push value things-processed) - (incf count) - (when (> count list-to-hash-table-threshold) - (let ((things things-processed)) - (setf things-processed - (make-hash-table :test 'eq)) - (dolist (thing things) - (setf (gethash thing things-processed) t))))) - (hash-table - (when (gethash value things-processed) - (return-from grovel nil)) - (setf (gethash value things-processed) t))) - (typecase value - (cons - (grovel (car value)) - (grovel (cdr value))) - (simple-vector - (dotimes (i (length value)) - (grovel (svref value i)))) - ((vector t) - (dotimes (i (length value)) - (grovel (aref value i)))) - ((simple-array t) - ;; Even though the (ARRAY T) branch does the exact - ;; same thing as this branch we do this separately - ;; so that the compiler can use faster versions of - ;; array-total-size and row-major-aref. - (dotimes (i (array-total-size value)) - (grovel (row-major-aref value i)))) - ((array t) - (dotimes (i (array-total-size value)) - (grovel (row-major-aref value i)))) - (;; In the target SBCL, we can dump any instance, - ;; but in the cross-compilation host, - ;; %INSTANCE-FOO functions don't work on general - ;; instances, only on STRUCTURE!OBJECTs. - #+sb-xc-host structure!object - #-sb-xc-host instance - (when (emit-make-load-form value) - (dotimes (i (- (%instance-length value) - #+sb-xc-host 0 - #-sb-xc-host (layout-n-untagged-slots - (%instance-ref value 0)))) - (grovel (%instance-ref value i))))) - (t - (compiler-error - "Objects of type ~S can't be dumped into fasl files." - (type-of value))))))) + ;; Unless VALUE is an object which which obviously + ;; can't contain other objects + (unless (typep value + '(or #-sb-xc-host unboxed-array + #+sb-xc-host (simple-array (unsigned-byte 8) (*)) + symbol + number + character + string)) + (etypecase things-processed + (list + (when (member value things-processed :test #'eq) + (return-from grovel nil)) + (push value things-processed) + (incf count) + (when (> count list-to-hash-table-threshold) + (let ((things things-processed)) + (setf things-processed + (make-hash-table :test 'eq)) + (dolist (thing things) + (setf (gethash thing things-processed) t))))) + (hash-table + (when (gethash value things-processed) + (return-from grovel nil)) + (setf (gethash value things-processed) t))) + (typecase value + (cons + (grovel (car value)) + (grovel (cdr value))) + (simple-vector + (dotimes (i (length value)) + (grovel (svref value i)))) + ((vector t) + (dotimes (i (length value)) + (grovel (aref value i)))) + ((simple-array t) + ;; Even though the (ARRAY T) branch does the exact + ;; same thing as this branch we do this separately + ;; so that the compiler can use faster versions of + ;; array-total-size and row-major-aref. + (dotimes (i (array-total-size value)) + (grovel (row-major-aref value i)))) + ((array t) + (dotimes (i (array-total-size value)) + (grovel (row-major-aref value i)))) + (;; In the target SBCL, we can dump any instance, + ;; but in the cross-compilation host, + ;; %INSTANCE-FOO functions don't work on general + ;; instances, only on STRUCTURE!OBJECTs. + #+sb-xc-host structure!object + #-sb-xc-host instance + (when (emit-make-load-form value) + (dotimes (i (- (%instance-length value) + #+sb-xc-host 0 + #-sb-xc-host (layout-n-untagged-slots + (%instance-ref value 0)))) + (grovel (%instance-ref value i))))) + (t + (compiler-error + "Objects of type ~S can't be dumped into fasl files." + (type-of value))))))) (grovel constant))) (values)) @@ -327,7 +327,7 @@ (defun %use-ctran (node ctran) (declare (type node node) (type ctran ctran) (inline member)) (let ((block (ctran-block ctran)) - (node-block (ctran-block (node-prev node)))) + (node-block (ctran-block (node-prev node)))) (aver (eq (ctran-kind ctran) :block-start)) (when (block-last node-block) (error "~S has already ended." node-block)) @@ -389,18 +389,18 @@ (defun ir1-toplevel (form path for-value) (declare (list path)) (let* ((*current-path* path) - (component (make-empty-component)) - (*current-component* component) + (component (make-empty-component)) + (*current-component* component) (*allow-instrumenting* t)) (setf (component-name component) 'initial-component) (setf (component-kind component) :initial) (let* ((forms (if for-value `(,form) `(,form nil))) - (res (ir1-convert-lambda-body - forms () - :debug-name (debug-name 'top-level-form form)))) + (res (ir1-convert-lambda-body + forms () + :debug-name (debug-name 'top-level-form form)))) (setf (functional-entry-fun res) res - (functional-arg-documentation res) () - (functional-kind res) :toplevel) + (functional-arg-documentation res) () + (functional-kind res) :toplevel) res))) ;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the @@ -425,45 +425,45 @@ (defun sub-find-source-paths (form path) (unless (gethash form *source-paths*) (setf (gethash form *source-paths*) - (list* 'original-source-start *current-form-number* path)) + (list* 'original-source-start *current-form-number* path)) (incf *current-form-number*) (let ((pos 0) - (subform form) - (trail form)) + (subform form) + (trail form)) (declare (fixnum pos)) (macrolet ((frob () - '(progn - (when (atom subform) (return)) - (let ((fm (car subform))) - (when (consp fm) - (sub-find-source-paths fm (cons pos path))) - (incf pos)) - (setq subform (cdr subform)) - (when (eq subform trail) (return))))) - (loop - (frob) - (frob) - (setq trail (cdr trail))))))) + '(progn + (when (atom subform) (return)) + (let ((fm (car subform))) + (when (consp fm) + (sub-find-source-paths fm (cons pos path))) + (incf pos)) + (setq subform (cdr subform)) + (when (eq subform trail) (return))))) + (loop + (frob) + (frob) + (setq trail (cdr trail))))))) ;;;; IR1-CONVERT, macroexpansion and special form dispatching (declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values)) - ir1-convert)) + ir1-convert)) (macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws - ;; out of the body and converts a condition signalling form - ;; instead. The source form is converted to a string since it - ;; may contain arbitrary non-externalizable objects. - (ir1-error-bailout ((start next result form) &body body) - (with-unique-names (skip condition) - `(block ,skip - (let ((,condition (catch 'ir1-error-abort - (let ((*compiler-error-bailout* - (lambda (&optional e) - (throw 'ir1-error-abort e)))) - ,@body - (return-from ,skip nil))))) - (ir1-convert ,start ,next ,result - (make-compiler-error-form ,condition ,form))))))) + ;; out of the body and converts a condition signalling form + ;; instead. The source form is converted to a string since it + ;; may contain arbitrary non-externalizable objects. + (ir1-error-bailout ((start next result form) &body body) + (with-unique-names (skip condition) + `(block ,skip + (let ((,condition (catch 'ir1-error-abort + (let ((*compiler-error-bailout* + (lambda (&optional e) + (throw 'ir1-error-abort e)))) + ,@body + (return-from ,skip nil))))) + (ir1-convert ,start ,next ,result + (make-compiler-error-form ,condition ,form))))))) ;; Translate FORM into IR1. The code is inserted as the NEXT of the ;; CTRAN START. RESULT is the LVAR which receives the value of the @@ -478,8 +478,8 @@ (defun ir1-convert (start next result form) (ir1-error-bailout (start next result form) (let ((*current-path* (or (gethash form *source-paths*) - (cons form *current-path*)))) - (cond ((step-form-p form) + (cons form *current-path*)))) + (cond ((step-form-p form) (ir1-convert-step start next result form)) ((atom form) (cond ((and (symbolp form) (not (keywordp form))) @@ -521,10 +521,10 @@ (ir1-convert-lambda opname :debug-name (debug-name - 'lambda-car + 'lambda-car opname)))))))))) (values)) - + ;; Generate a reference to a manifest constant, creating a new leaf ;; if necessary. If we are producing a fasl file, make sure that ;; MAKE-LOAD-FORM gets used on any parts of the constant that it @@ -532,12 +532,12 @@ (defun reference-constant (start next result value) (declare (type ctran start next) (type (or lvar null) result) - (inline find-constant)) + (inline find-constant)) (ir1-error-bailout (start next result value) (when (producing-fasl-file) (maybe-emit-make-load-forms value)) (let* ((leaf (find-constant value)) - (res (make-ref leaf))) + (res (make-ref leaf))) (push res (leaf-refs leaf)) (link-node-to-previous-ctran res start) (use-continuation res next result))) @@ -562,7 +562,7 @@ (aver (eql (lambda-component functional) *current-component*))) (pushnew functional - (component-reanalyze-functionals *current-component*))) + (component-reanalyze-functionals *current-component*))) functional) @@ -619,18 +619,18 @@ (etypecase var (leaf (when (lambda-var-p var) - (let ((home (ctran-home-lambda-or-null start))) - (when home - (pushnew var (lambda-calls-or-closes home)))) - (when (lambda-var-ignorep var) - ;; (ANSI's specification for the IGNORE declaration requires - ;; that this be a STYLE-WARNING, not a full WARNING.) - #-sb-xc-host - (compiler-style-warn "reading an ignored variable: ~S" name) - ;; there's no need for us to accept ANSI's lameness when - ;; processing our own code, though. - #+sb-xc-host - (warn "reading an ignored variable: ~S" name))) + (let ((home (ctran-home-lambda-or-null start))) + (when home + (pushnew var (lambda-calls-or-closes home)))) + (when (lambda-var-ignorep var) + ;; (ANSI's specification for the IGNORE declaration requires + ;; that this be a STYLE-WARNING, not a full WARNING.) + #-sb-xc-host + (compiler-style-warn "reading an ignored variable: ~S" name) + ;; there's no need for us to accept ANSI's lameness when + ;; processing our own code, though. + #+sb-xc-host + (warn "reading an ignored variable: ~S" name))) (reference-leaf start next result var)) (cons (aver (eq (car var) 'macro)) @@ -645,27 +645,27 @@ (defun ir1-convert-global-functoid (start next result form) (declare (type ctran start next) (type (or lvar null) result) (list form)) (let* ((fun-name (first form)) - (translator (info :function :ir1-convert fun-name)) - (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*))) + (translator (info :function :ir1-convert fun-name)) + (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*))) (cond (translator - (when cmacro-fun - (compiler-warn "ignoring compiler macro for special form")) - (funcall translator start next result form)) - ((and cmacro-fun - ;; gotcha: If you look up the DEFINE-COMPILER-MACRO - ;; macro in the ANSI spec, you might think that - ;; suppressing compiler-macro expansion when NOTINLINE - ;; is some pre-ANSI hack. However, if you look up the - ;; NOTINLINE declaration, you'll find that ANSI - ;; requires this behavior after all. - (not (eq (info :function :inlinep fun-name) :notinline))) - (let ((res (careful-expand-macro cmacro-fun form))) - (if (eq res form) - (ir1-convert-global-functoid-no-cmacro - start next result form fun-name) - (ir1-convert start next result res)))) - (t - (ir1-convert-global-functoid-no-cmacro start next result + (when cmacro-fun + (compiler-warn "ignoring compiler macro for special form")) + (funcall translator start next result form)) + ((and cmacro-fun + ;; gotcha: If you look up the DEFINE-COMPILER-MACRO + ;; macro in the ANSI spec, you might think that + ;; suppressing compiler-macro expansion when NOTINLINE + ;; is some pre-ANSI hack. However, if you look up the + ;; NOTINLINE declaration, you'll find that ANSI + ;; requires this behavior after all. + (not (eq (info :function :inlinep fun-name) :notinline))) + (let ((res (careful-expand-macro cmacro-fun form))) + (if (eq res form) + (ir1-convert-global-functoid-no-cmacro + start next result form fun-name) + (ir1-convert start next result res)))) + (t + (ir1-convert-global-functoid-no-cmacro start next result form fun-name))))) ;;; Handle the case of where the call was not a compiler macro, or was @@ -680,12 +680,12 @@ (ecase (info :function :kind fun) (:macro (ir1-convert start next result - (careful-expand-macro (info :function :macro-function fun) - form))) + (careful-expand-macro (info :function :macro-function fun) + form))) ((nil :function) (ir1-convert-srctran start next result - (find-free-fun fun "shouldn't happen! (no-cmacro)") - form)))) + (find-free-fun fun "shouldn't happen! (no-cmacro)") + form)))) (defun muffle-warning-or-die () (muffle-warning) @@ -695,27 +695,27 @@ ;;; errors which occur during the macroexpansion. (defun careful-expand-macro (fun form) (let (;; a hint I (WHN) wish I'd known earlier - (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)")) + (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)")) (flet (;; Return a string to use as a prefix in error reporting, - ;; telling something about which form caused the problem. - (wherestring () - (let ((*print-pretty* nil) - ;; We rely on the printer to abbreviate FORM. - (*print-length* 3) - (*print-level* 1)) - (format - nil - #-sb-xc-host "(in macroexpansion of ~S)" - ;; longer message to avoid ambiguity "Was it the xc host - ;; or the cross-compiler which encountered the problem?" - #+sb-xc-host "(in cross-compiler macroexpansion of ~S)" - form)))) + ;; telling something about which form caused the problem. + (wherestring () + (let ((*print-pretty* nil) + ;; We rely on the printer to abbreviate FORM. + (*print-length* 3) + (*print-level* 1)) + (format + nil + #-sb-xc-host "(in macroexpansion of ~S)" + ;; longer message to avoid ambiguity "Was it the xc host + ;; or the cross-compiler which encountered the problem?" + #+sb-xc-host "(in cross-compiler macroexpansion of ~S)" + form)))) (handler-bind ((style-warning (lambda (c) - (compiler-style-warn - "~@<~A~:@_~A~@:_~A~:>" - (wherestring) hint c) - (muffle-warning-or-die))) - ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for + (compiler-style-warn + "~@<~A~:@_~A~@:_~A~:>" + (wherestring) hint c) + (muffle-warning-or-die))) + ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for ;; Debian Linux, anyway) raises a CL:WARNING ;; condition (not a CL:STYLE-WARNING) for undefined ;; symbols when converting interpreted functions, @@ -747,11 +747,11 @@ (wherestring) c) (muffle-warning-or-die))) - #-(and cmu sb-xc-host) - (warning (lambda (c) - (warn "~@<~A~:@_~A~@:_~A~:>" - (wherestring) hint c) - (muffle-warning-or-die))) + #-(and cmu sb-xc-host) + (warning (lambda (c) + (warn "~@<~A~:@_~A~@:_~A~:>" + (wherestring) hint c) + (muffle-warning-or-die))) (error (lambda (c) (compiler-error "~@<~A~:@_~A~@:_~A~:>" (wherestring) hint c)))) @@ -762,21 +762,21 @@ ;;; Convert a bunch of forms, discarding all the values except the ;;; last. If there aren't any forms, then translate a NIL. (declaim (ftype (sfunction (ctran ctran (or lvar null) list) (values)) - ir1-convert-progn-body)) + ir1-convert-progn-body)) (defun ir1-convert-progn-body (start next result body) (if (endp body) (reference-constant start next result nil) (let ((this-start start) - (forms body)) - (loop - (let ((form (car forms))) - (when (endp (cdr forms)) - (ir1-convert this-start next result form) - (return)) - (let ((this-ctran (make-ctran))) - (ir1-convert this-start this-ctran nil form) - (setq this-start this-ctran - forms (cdr forms))))))) + (forms body)) + (loop + (let ((form (car forms))) + (when (endp (cdr forms)) + (ir1-convert this-start next result form) + (return)) + (let ((this-ctran (make-ctran))) + (ir1-convert this-start this-ctran nil form) + (setq this-start this-ctran + forms (cdr forms))))))) (values)) ;;;; converting combinations @@ -785,7 +785,7 @@ ;;; the source for the call. We return the COMBINATION node so that ;;; the caller can poke at it if it wants to. (declaim (ftype (sfunction (ctran ctran (or lvar null) list leaf) combination) - ir1-convert-combination)) + ir1-convert-combination)) (defun ir1-convert-combination (start next result form fun) (let ((ctran (make-ctran)) (fun-lvar (make-lvar))) @@ -805,15 +805,15 @@ (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) (let ((this-start start)) - (dolist (arg args) - (let ((this-ctran (make-ctran)) + (dolist (arg args) + (let ((this-ctran (make-ctran)) (this-lvar (make-lvar node))) - (ir1-convert this-start this-ctran this-lvar arg) - (setq this-start this-ctran) - (arg-lvars this-lvar))) - (link-node-to-previous-ctran node this-start) - (use-continuation node next result) - (setf (combination-args node) (arg-lvars)))) + (ir1-convert this-start this-ctran this-lvar arg) + (setq this-start this-ctran) + (arg-lvars this-lvar))) + (link-node-to-previous-ctran node this-start) + (use-continuation node next result) + (setf (combination-args node) (arg-lvars)))) node)) ;;; Convert a call to a global function. If not :NOTINLINE, then we do @@ -825,17 +825,17 @@ (declare (type ctran start next) (type (or lvar null) result) (type global-var var)) (let ((inlinep (when (defined-fun-p var) - (defined-fun-inlinep var)))) + (defined-fun-inlinep var)))) (if (eq inlinep :notinline) - (ir1-convert-combination start next result form var) - (let ((transform (info :function - :source-transform - (leaf-source-name var)))) + (ir1-convert-combination start next result form var) + (let ((transform (info :function + :source-transform + (leaf-source-name var)))) (if transform (multiple-value-bind (transformed pass) (funcall transform form) (if pass (ir1-convert-maybe-predicate start next result form var) - (ir1-convert start next result transformed))) + (ir1-convert start next result transformed))) (ir1-convert-maybe-predicate start next result form var)))))) ;;; If the function has the PREDICATE attribute, and the RESULT's DEST @@ -851,10 +851,10 @@ (type global-var var)) (let ((info (info :function :info (leaf-source-name var)))) (if (and info - (ir1-attributep (fun-info-attributes info) predicate) - (not (if-p (and result (lvar-dest result))))) - (ir1-convert start next result `(if ,form t nil)) - (ir1-convert-combination-checking-type start next result form var)))) + (ir1-attributep (fun-info-attributes info) predicate) + (not (if-p (and result (lvar-dest result))))) + (ir1-convert start next result `(if ,form t nil)) + (ir1-convert-combination-checking-type start next result form var)))) ;;; Actually really convert a global function call that we are allowed ;;; to early-bind. @@ -875,8 +875,8 @@ (list form) (type leaf var)) (let* ((node (ir1-convert-combination start next result form var)) - (fun-lvar (basic-combination-fun node)) - (type (leaf-type var))) + (fun-lvar (basic-combination-fun node)) + (type (leaf-type var))) (when (validate-call-type node type t) (setf (lvar-%derived-type fun-lvar) (make-single-value-type type)) @@ -891,8 +891,8 @@ (defun ir1-convert-local-combination (start next result form functional) (assure-functional-live-p functional) (ir1-convert-combination start next result - form - (maybe-reanalyze-functional functional))) + form + (maybe-reanalyze-functional functional))) ;;;; PROCESS-DECLS @@ -901,21 +901,21 @@ ;;; *last* variable with that name, since LET* bindings may be ;;; duplicated, and declarations always apply to the last. (declaim (ftype (sfunction (list symbol) (or lambda-var list)) - find-in-bindings)) + find-in-bindings)) (defun find-in-bindings (vars name) (let ((found nil)) (dolist (var vars) (cond ((leaf-p var) - (when (eq (leaf-source-name var) name) - (setq found var)) - (let ((info (lambda-var-arg-info var))) - (when info - (let ((supplied-p (arg-info-supplied-p info))) - (when (and supplied-p - (eq (leaf-source-name supplied-p) name)) - (setq found supplied-p)))))) - ((and (consp var) (eq (car var) name)) - (setf found (cdr var))))) + (when (eq (leaf-source-name var) name) + (setq found var)) + (let ((info (lambda-var-arg-info var))) + (when info + (let ((supplied-p (arg-info-supplied-p info))) + (when (and supplied-p + (eq (leaf-source-name supplied-p) name)) + (setq found supplied-p)))))) + ((and (consp var) (eq (car var) name)) + (setf found (cdr var))))) found)) ;;; Called by PROCESS-DECLS to deal with a variable type declaration. @@ -928,57 +928,57 @@ (collect ((restr nil cons) (new-vars nil cons)) (dolist (var-name (rest decl)) - (when (boundp var-name) + (when (boundp var-name) (compiler-assert-symbol-home-package-unlocked - var-name "declaring the type of ~A")) - (let* ((bound-var (find-in-bindings vars var-name)) - (var (or bound-var - (lexenv-find var-name vars) - (find-free-var var-name)))) - (etypecase var - (leaf - (flet - ((process-var (var bound-var) - (let* ((old-type (or (lexenv-find var type-restrictions) - (leaf-type var))) - (int (if (or (fun-type-p type) - (fun-type-p old-type)) - type - (type-approx-intersection2 - old-type type)))) - (cond ((eq int *empty-type*) - (unless (policy *lexenv* (= inhibit-warnings 3)) - (warn - 'type-warning - :format-control - "The type declarations ~S and ~S for ~S conflict." - :format-arguments - (list - (type-specifier old-type) - (type-specifier type) - var-name)))) - (bound-var (setf (leaf-type bound-var) int)) - (t - (restr (cons var int))))))) + var-name "declaring the type of ~A")) + (let* ((bound-var (find-in-bindings vars var-name)) + (var (or bound-var + (lexenv-find var-name vars) + (find-free-var var-name)))) + (etypecase var + (leaf + (flet + ((process-var (var bound-var) + (let* ((old-type (or (lexenv-find var type-restrictions) + (leaf-type var))) + (int (if (or (fun-type-p type) + (fun-type-p old-type)) + type + (type-approx-intersection2 + old-type type)))) + (cond ((eq int *empty-type*) + (unless (policy *lexenv* (= inhibit-warnings 3)) + (warn + 'type-warning + :format-control + "The type declarations ~S and ~S for ~S conflict." + :format-arguments + (list + (type-specifier old-type) + (type-specifier type) + var-name)))) + (bound-var (setf (leaf-type bound-var) int)) + (t + (restr (cons var int))))))) (process-var var bound-var) (awhen (and (lambda-var-p var) (lambda-var-specvar var)) (process-var it nil)))) - (cons - ;; FIXME: non-ANSI weirdness - (aver (eq (car var) 'macro)) - (new-vars `(,var-name . (macro . (the ,(first decl) + (cons + ;; FIXME: non-ANSI weirdness + (aver (eq (car var) 'macro)) + (new-vars `(,var-name . (macro . (the ,(first decl) ,(cdr var)))))) - (heap-alien-info - (compiler-error - "~S is an alien variable, so its type can't be declared." - var-name))))) + (heap-alien-info + (compiler-error + "~S is an alien variable, so its type can't be declared." + var-name))))) (if (or (restr) (new-vars)) - (make-lexenv :default res - :type-restrictions (restr) - :vars (new-vars)) - res)))) + (make-lexenv :default res + :type-restrictions (restr) + :vars (new-vars)) + res)))) ;;; This is somewhat similar to PROCESS-TYPE-DECL, but handles ;;; declarations for function variables. In addition to allowing @@ -991,118 +991,118 @@ (let ((type (compiler-specifier-type spec))) (collect ((res nil cons)) (dolist (name names) - (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "declaring the ftype of ~A")) - (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) - (cond - (found - (setf (leaf-type found) type) - (assert-definition-type found type - :unwinnage-fun #'compiler-notify - :where "FTYPE declaration")) - (t - (res (cons (find-lexically-apparent-fun - name "in a function type declaration") - type)))))) + (when (fboundp name) + (compiler-assert-symbol-home-package-unlocked + name "declaring the ftype of ~A")) + (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) + (cond + (found + (setf (leaf-type found) type) + (assert-definition-type found type + :unwinnage-fun #'compiler-notify + :where "FTYPE declaration")) + (t + (res (cons (find-lexically-apparent-fun + name "in a function type declaration") + type)))))) (if (res) - (make-lexenv :default res :type-restrictions (res)) - res)))) + (make-lexenv :default res :type-restrictions (res)) + res)))) ;;; Process a special declaration, returning a new LEXENV. A non-bound ;;; special declaration is instantiated by throwing a special variable ;;; into the variables if BINDING-FORM-P is NIL, or otherwise into -;;; *POST-BINDING-VARIABLE-LEXENV*. +;;; *POST-BINDING-VARIABLE-LEXENV*. (defun process-special-decl (spec res vars binding-form-p) (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) (compiler-assert-symbol-home-package-unlocked name "declaring ~A special") (let ((var (find-in-bindings vars name))) - (etypecase var - (cons - (aver (eq (car var) 'macro)) - (compiler-error - "~S is a symbol-macro and thus can't be declared special." - name)) - (lambda-var - (when (lambda-var-ignorep var) - ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" - ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warn - "The ignored variable ~S is being declared special." - name)) - (setf (lambda-var-specvar var) - (specvar-for-binding name))) - (null - (unless (or (assoc name (new-venv) :test #'eq)) - (new-venv (cons name (specvar-for-binding name)))))))) + (etypecase var + (cons + (aver (eq (car var) 'macro)) + (compiler-error + "~S is a symbol-macro and thus can't be declared special." + name)) + (lambda-var + (when (lambda-var-ignorep var) + ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" + ;; requires that this be a STYLE-WARNING, not a full WARNING. + (compiler-style-warn + "The ignored variable ~S is being declared special." + name)) + (setf (lambda-var-specvar var) + (specvar-for-binding name))) + (null + (unless (or (assoc name (new-venv) :test #'eq)) + (new-venv (cons name (specvar-for-binding name)))))))) (cond (binding-form-p - (setf *post-binding-variable-lexenv* - (append (new-venv) *post-binding-variable-lexenv*)) - res) - ((new-venv) - (make-lexenv :default res :vars (new-venv))) - (t - res)))) + (setf *post-binding-variable-lexenv* + (append (new-venv) *post-binding-variable-lexenv*)) + res) + ((new-venv) + (make-lexenv :default res :vars (new-venv))) + (t + res)))) ;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP ;;; (and TYPE if notinline), plus type-restrictions from the lexenv. (defun make-new-inlinep (var inlinep local-type) (declare (type global-var var) (type inlinep inlinep)) (let* ((type (if (and (eq inlinep :notinline) - (not (eq (leaf-where-from var) :declared))) - (specifier-type 'function) - (leaf-type var))) - (res (make-defined-fun - :%source-name (leaf-source-name var) - :where-from (leaf-where-from var) - :type (if local-type - (type-intersection local-type type) - type) - :inlinep inlinep))) + (not (eq (leaf-where-from var) :declared))) + (specifier-type 'function) + (leaf-type var))) + (res (make-defined-fun + :%source-name (leaf-source-name var) + :where-from (leaf-where-from var) + :type (if local-type + (type-intersection local-type type) + type) + :inlinep inlinep))) (when (defined-fun-p var) (setf (defined-fun-inline-expansion res) - (defined-fun-inline-expansion var)) + (defined-fun-inline-expansion var)) (setf (defined-fun-functional res) - (defined-fun-functional var))) + (defined-fun-functional var))) res)) ;;; Parse an inline/notinline declaration. If it's a local function we're ;;; defining, set its INLINEP. If a global function, add a new FENV entry. (defun process-inline-decl (spec res fvars) (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq))) - (new-fenv ())) + (new-fenv ())) (dolist (name (rest spec)) (let ((fvar (find name fvars :key #'leaf-source-name :test #'equal))) - (if fvar - (setf (functional-inlinep fvar) sense) - (let ((found (find-lexically-apparent-fun - name "in an inline or notinline declaration"))) - (etypecase found - (functional - (when (policy *lexenv* (>= speed inhibit-warnings)) - (compiler-notify "ignoring ~A declaration not at ~ + (if fvar + (setf (functional-inlinep fvar) sense) + (let ((found (find-lexically-apparent-fun + name "in an inline or notinline declaration"))) + (etypecase found + (functional + (when (policy *lexenv* (>= speed inhibit-warnings)) + (compiler-notify "ignoring ~A declaration not at ~ definition of local function:~% ~S" - sense name))) - (global-var - (let ((type - (cdr (assoc found (lexenv-type-restrictions res))))) - (push (cons name (make-new-inlinep found sense type)) - new-fenv)))))))) + sense name))) + (global-var + (let ((type + (cdr (assoc found (lexenv-type-restrictions res))))) + (push (cons name (make-new-inlinep found sense type)) + new-fenv)))))))) (if new-fenv - (make-lexenv :default res :funs new-fenv) - res))) + (make-lexenv :default res :funs new-fenv) + res))) ;;; like FIND-IN-BINDINGS, but looks for #'FOO in the FVARS (defun find-in-bindings-or-fbindings (name vars fvars) (declare (list vars fvars)) (if (consp name) (destructuring-bind (wot fn-name) name - (unless (eq wot 'function) - (compiler-error "The function or variable name ~S is unrecognizable." - name)) - (find fn-name fvars :key #'leaf-source-name :test #'equal)) + (unless (eq wot 'function) + (compiler-error "The function or variable name ~S is unrecognizable." + name)) + (find fn-name fvars :key #'leaf-source-name :test #'equal)) (find-in-bindings vars name))) ;;; Process an ignore/ignorable declaration, checking for various losing @@ -1113,74 +1113,74 @@ (let ((var (find-in-bindings-or-fbindings name vars fvars))) (cond ((not var) - ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" - ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warn "declaring unknown variable ~S to be ignored" - name)) + ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" + ;; requires that this be a STYLE-WARNING, not a full WARNING. + (compiler-style-warn "declaring unknown variable ~S to be ignored" + name)) ;; FIXME: This special case looks like non-ANSI weirdness. ((and (consp var) (eq (car var) 'macro)) - ;; Just ignore the IGNORE decl. - ) + ;; Just ignore the IGNORE decl. + ) ((functional-p var) - (setf (leaf-ever-used var) t)) + (setf (leaf-ever-used var) t)) ((and (lambda-var-specvar var) (eq (first spec) 'ignore)) - ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" - ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warn "declaring special variable ~S to be ignored" - name)) + ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" + ;; requires that this be a STYLE-WARNING, not a full WARNING. + (compiler-style-warn "declaring special variable ~S to be ignored" + name)) ((eq (first spec) 'ignorable) - (setf (leaf-ever-used var) t)) + (setf (leaf-ever-used var) t)) (t - (setf (lambda-var-ignorep var) t))))) + (setf (lambda-var-ignorep var) t))))) (values)) (defun process-dx-decl (names vars fvars) (flet ((maybe-notify (control &rest args) - (when (policy *lexenv* (> speed inhibit-warnings)) - (apply #'compiler-notify control args)))) + (when (policy *lexenv* (> speed inhibit-warnings)) + (apply #'compiler-notify control args)))) (if (policy *lexenv* (= stack-allocate-dynamic-extent 3)) - (dolist (name names) - (cond - ((symbolp name) - (let* ((bound-var (find-in-bindings vars name)) - (var (or bound-var - (lexenv-find name vars) - (find-free-var name)))) - (etypecase var - (leaf - (if bound-var - (setf (leaf-dynamic-extent var) t) - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - name))) - (cons - (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) - (heap-alien-info - (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" - name))))) - ((and (consp name) - (eq (car name) 'function) - (null (cddr name)) - (valid-function-name-p (cadr name))) + (dolist (name names) + (cond + ((symbolp name) + (let* ((bound-var (find-in-bindings vars name)) + (var (or bound-var + (lexenv-find name vars) + (find-free-var name)))) + (etypecase var + (leaf + (if bound-var + (setf (leaf-dynamic-extent var) t) + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + name))) + (cons + (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) + (heap-alien-info + (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" + name))))) + ((and (consp name) + (eq (car name) 'function) + (null (cddr name)) + (valid-function-name-p (cadr name))) (let* ((fname (cadr name)) (bound-fun (find fname fvars :key #'leaf-source-name :test #'equal))) - (etypecase bound-fun - (leaf + (etypecase bound-fun + (leaf #!+stack-allocatable-closures - (setf (leaf-dynamic-extent bound-fun) t) + (setf (leaf-dynamic-extent bound-fun) t) #!-stack-allocatable-closures (maybe-notify "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ (not supported on this platform)." fname)) - (cons - (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) + (cons + (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) (null (maybe-notify "ignoring DYNAMIC-EXTENT declaration for free ~S" fname))))) - (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) + (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names)))) ;;; FIXME: This is non-ANSI, so the default should be T, or it should @@ -1214,15 +1214,15 @@ :default res :policy (process-optimize-decl spec (lexenv-policy res)))) (muffle-conditions - (make-lexenv - :default res - :handled-conditions (process-muffle-conditions-decl - spec (lexenv-handled-conditions res)))) + (make-lexenv + :default res + :handled-conditions (process-muffle-conditions-decl + spec (lexenv-handled-conditions res)))) (unmuffle-conditions - (make-lexenv - :default res - :handled-conditions (process-unmuffle-conditions-decl - spec (lexenv-handled-conditions res)))) + (make-lexenv + :default res + :handled-conditions (process-unmuffle-conditions-decl + spec (lexenv-handled-conditions res)))) (type (process-type-decl (cdr spec) res vars)) (values @@ -1235,7 +1235,7 @@ `(values ,@types))))) res)) (dynamic-extent - (process-dx-decl (cdr spec) vars fvars) + (process-dx-decl (cdr spec) vars fvars) res) ((disable-package-locks enable-package-locks) (make-lexenv @@ -1260,10 +1260,10 @@ ;;; This is also called in main.lisp when PROCESS-FORM handles a use ;;; of LOCALLY. (defun process-decls (decls vars fvars &key (lexenv *lexenv*) - (binding-form-p nil)) + (binding-form-p nil)) (declare (list decls vars fvars)) (let ((result-type *wild-type*) - (*post-binding-variable-lexenv* nil)) + (*post-binding-variable-lexenv* nil)) (dolist (decl decls) (dolist (spec (rest decl)) (unless (consp spec) @@ -1292,17 +1292,17 @@ (setf (lvar-dest value-lvar) cast) (use-continuation cast ctran lvar)))))))) (defmacro processing-decls ((decls vars fvars ctran lvar - &optional post-binding-lexenv) - &body forms) + &optional post-binding-lexenv) + &body forms) (check-type ctran symbol) (check-type lvar symbol) (let ((post-binding-lexenv-p (not (null post-binding-lexenv))) - (post-binding-lexenv (or post-binding-lexenv (gensym)))) + (post-binding-lexenv (or post-binding-lexenv (gensym)))) `(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar - ,post-binding-lexenv-p - (lambda (,ctran ,lvar ,post-binding-lexenv) - (declare (ignorable ,post-binding-lexenv)) - ,@forms)))) + ,post-binding-lexenv-p + (lambda (,ctran ,lvar ,post-binding-lexenv) + (declare (ignorable ,post-binding-lexenv)) + ,@forms)))) ;;; Return the SPECVAR for NAME to use when we see a local SPECIAL ;;; declaration. If there is a global variable of that name, then @@ -1310,17 +1310,17 @@ ;;; anonymous GLOBAL-VAR. (defun specvar-for-binding (name) (cond ((not (eq (info :variable :where-from name) :assumed)) - (let ((found (find-free-var name))) - (when (heap-alien-info-p found) - (compiler-error - "~S is an alien variable and so can't be declared special." - name)) - (unless (global-var-p found) - (compiler-error - "~S is a constant and so can't be declared special." - name)) - found)) - (t - (make-global-var :kind :special - :%source-name name - :where-from :declared)))) + (let ((found (find-free-var name))) + (when (heap-alien-info-p found) + (compiler-error + "~S is an alien variable and so can't be declared special." + name)) + (unless (global-var-p found) + (compiler-error + "~S is a constant and so can't be declared special." + name)) + found)) + (t + (make-global-var :kind :special + :%source-name name + :where-from :declared)))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 0efb8ae..cd08ee2 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -20,7 +20,7 @@ (defun node-enclosing-cleanup (node) (declare (type node node)) (do ((lexenv (node-lexenv node) - (lambda-call-lexenv (lexenv-lambda lexenv)))) + (lambda-call-lexenv (lexenv-lambda lexenv)))) ((null lexenv) nil) (let ((cup (lexenv-cleanup lexenv))) (when cup (return cup))))) @@ -34,7 +34,7 @@ ;;; that cleanup. (defun insert-cleanup-code (block1 block2 node form &optional cleanup) (declare (type cblock block1 block2) (type node node) - (type (or cleanup null) cleanup)) + (type (or cleanup null) cleanup)) (setf (component-reanalyze (block-component block1)) t) (with-ir1-environment-from-node node (with-component-last-block (*current-component* @@ -156,9 +156,9 @@ (exit (setf (exit-value dest) new)) (basic-combination (if (eq old (basic-combination-fun dest)) - (setf (basic-combination-fun dest) new) - (setf (basic-combination-args dest) - (nsubst new old (basic-combination-args dest))))) + (setf (basic-combination-fun dest) new) + (setf (basic-combination-args dest) + (nsubst new old (basic-combination-args dest))))) (cast (setf (cast-value dest) new))) (setf (lvar-dest old) nil) @@ -358,7 +358,7 @@ (defun node-home-lambda (node) (declare (type node node)) (do ((fun (lexenv-lambda (node-lexenv node)) - (lexenv-lambda (lambda-call-lexenv fun)))) + (lexenv-lambda (lambda-call-lexenv fun)))) ((not (memq (functional-kind fun) '(:deleted :zombie))) (lambda-home fun)) (when (eq (lambda-home fun) fun) @@ -428,25 +428,25 @@ ;; 1. It can fail in a few cases even when a meaningful home ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of ;; an IF. - ;; 2. It can fail when converting a form which is born orphaned + ;; 2. It can fail when converting a form which is born orphaned ;; so that it never had a meaningful home lambda, e.g. a form ;; which follows a RETURN-FROM or GO form. (let ((pred-list (block-pred block))) - ;; To deal with case 1, we reason that - ;; previous-in-target-execution-order blocks should be in the - ;; same lambda, and that they seem in practice to be - ;; previous-in-compilation-order blocks too, so we look back - ;; to find one which is sufficiently initialized to tell us - ;; what the home lambda is. - (if pred-list - ;; We could get fancy about this, flooding through the - ;; graph of all the previous blocks, but in practice it - ;; seems to work just to grab the first previous block and - ;; use it. - (node-home-lambda (block-last (first pred-list))) - ;; In case 2, we end up with an empty PRED-LIST and - ;; have to punt: There's no home lambda. - nil)))) + ;; To deal with case 1, we reason that + ;; previous-in-target-execution-order blocks should be in the + ;; same lambda, and that they seem in practice to be + ;; previous-in-compilation-order blocks too, so we look back + ;; to find one which is sufficiently initialized to tell us + ;; what the home lambda is. + (if pred-list + ;; We could get fancy about this, flooding through the + ;; graph of all the previous blocks, but in practice it + ;; seems to work just to grab the first previous block and + ;; use it. + (node-home-lambda (block-last (first pred-list))) + ;; In case 2, we end up with an empty PRED-LIST and + ;; have to punt: There's no home lambda. + nil)))) ;;; Return the non-LET LAMBDA that holds BLOCK's code. (declaim (ftype (sfunction (cblock) clambda) block-home-lambda)) @@ -487,18 +487,18 @@ (defun node-source-form (node) (declare (type node node)) (let* ((path (node-source-path node)) - (forms (source-path-forms path))) + (forms (source-path-forms path))) (if forms - (first forms) - (values (find-original-source path))))) + (first forms) + (values (find-original-source path))))) ;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise ;;; NIL, NIL. (defun lvar-source (lvar) (let ((use (lvar-uses lvar))) (if (listp use) - (values nil nil) - (values (node-source-form use) t)))) + (values nil nil) + (values (node-source-form use) t)))) ;;; Return the unique node, delivering a value to LVAR. #!-sb-fluid (declaim (inline lvar-use)) @@ -523,11 +523,11 @@ ;; approach fails, and furthermore realize that in some exceptional ;; cases it might return NIL. -- WHN 2001-12-04 (cond ((ctran-use ctran) - (node-home-lambda (ctran-use ctran))) - ((ctran-block ctran) - (block-home-lambda-or-null (ctran-block ctran))) - (t - (bug "confused about home lambda for ~S" ctran)))) + (node-home-lambda (ctran-use ctran))) + ((ctran-block ctran) + (block-home-lambda-or-null (ctran-block ctran))) + (t + (bug "confused about home lambda for ~S" ctran)))) ;;; Return the LAMBDA that is CTRAN's home. (declaim (ftype (sfunction (ctran) clambda) ctran-home-lambda)) @@ -574,26 +574,26 @@ ;;; slot values. Values for the alist slots are NCONCed to the ;;; beginning of the current value, rather than replacing it entirely. (defun make-lexenv (&key (default *lexenv*) - funs vars blocks tags + funs vars blocks tags type-restrictions - (lambda (lexenv-lambda default)) - (cleanup (lexenv-cleanup default)) - (handled-conditions (lexenv-handled-conditions default)) - (disabled-package-locks - (lexenv-disabled-package-locks default)) - (policy (lexenv-policy default))) + (lambda (lexenv-lambda default)) + (cleanup (lexenv-cleanup default)) + (handled-conditions (lexenv-handled-conditions default)) + (disabled-package-locks + (lexenv-disabled-package-locks default)) + (policy (lexenv-policy default))) (macrolet ((frob (var slot) - `(let ((old (,slot default))) - (if ,var - (nconc ,var old) - old)))) + `(let ((old (,slot default))) + (if ,var + (nconc ,var old) + old)))) (internal-make-lexenv (frob funs lexenv-funs) (frob vars lexenv-vars) (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup handled-conditions + lambda cleanup handled-conditions disabled-package-locks policy))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced @@ -633,9 +633,9 @@ (defun link-blocks (block1 block2) (declare (type cblock block1 block2)) (setf (block-succ block1) - (if (block-succ block1) - (%link-blocks block1 block2) - (list block2))) + (if (block-succ block1) + (%link-blocks block1 block2) + (list block2))) (push block1 (block-pred block2)) (values)) (defun %link-blocks (block1 block2) @@ -652,19 +652,19 @@ (declare (type cblock block1 block2)) (let ((succ1 (block-succ block1))) (if (eq block2 (car succ1)) - (setf (block-succ block1) (cdr succ1)) - (do ((succ (cdr succ1) (cdr succ)) - (prev succ1 succ)) - ((eq (car succ) block2) - (setf (cdr prev) (cdr succ))) - (aver succ)))) + (setf (block-succ block1) (cdr succ1)) + (do ((succ (cdr succ1) (cdr succ)) + (prev succ1 succ)) + ((eq (car succ) block2) + (setf (cdr prev) (cdr succ))) + (aver succ)))) (let ((new-pred (delq block1 (block-pred block2)))) (setf (block-pred block2) new-pred) (when (singleton-p new-pred) (let ((pred-block (first new-pred))) - (when (if-p (block-last pred-block)) - (setf (block-test-modified pred-block) t))))) + (when (if-p (block-last pred-block)) + (setf (block-test-modified pred-block) t))))) (values)) ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK @@ -676,29 +676,29 @@ (declare (type cblock new old block)) (unlink-blocks block old) (let ((last (block-last block)) - (comp (block-component block))) + (comp (block-component block))) (setf (component-reanalyze comp) t) (typecase last (cif (setf (block-test-modified block) t) (let* ((succ-left (block-succ block)) - (new (if (and (eq new (component-tail comp)) - succ-left) - (first succ-left) - new))) - (unless (memq new succ-left) - (link-blocks block new)) - (macrolet ((frob (slot) - `(when (eq (,slot last) old) - (setf (,slot last) new)))) - (frob if-consequent) - (frob if-alternative) + (new (if (and (eq new (component-tail comp)) + succ-left) + (first succ-left) + new))) + (unless (memq new succ-left) + (link-blocks block new)) + (macrolet ((frob (slot) + `(when (eq (,slot last) old) + (setf (,slot last) new)))) + (frob if-consequent) + (frob if-alternative) (when (eq (if-consequent last) (if-alternative last)) (reoptimize-component (block-component block) :maybe))))) (t (unless (memq new (block-succ block)) - (link-blocks block new))))) + (link-blocks block new))))) (values)) @@ -707,7 +707,7 @@ (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo)) (defun remove-from-dfo (block) (let ((next (block-next block)) - (prev (block-prev block))) + (prev (block-prev block))) (setf (block-component block) nil) (setf (block-next prev) next) (setf (block-prev next) prev)) @@ -718,7 +718,7 @@ (defun add-to-dfo (block after) (declare (type cblock block after)) (let ((next (block-next after)) - (comp (block-component after))) + (comp (block-component after))) (aver (not (eq (component-kind comp) :deleted))) (setf (block-component block) comp) (setf (block-next after) block) @@ -759,7 +759,7 @@ (declaim (ftype (sfunction (component) (values)) clear-flags)) (defun clear-flags (component) (let ((head (component-head component)) - (tail (component-tail component))) + (tail (component-tail component))) (setf (block-flag head) t) (setf (block-flag tail) t) (do-blocks (block component) @@ -771,8 +771,8 @@ (declaim (ftype (sfunction () component) make-empty-component)) (defun make-empty-component () (let* ((head (make-block-key :start nil :component nil)) - (tail (make-block-key :start nil :component nil)) - (res (make-component head tail))) + (tail (make-block-key :start nil :component nil)) + (res (make-component head tail))) (setf (block-flag head) t) (setf (block-flag tail) t) (setf (block-component head) res) @@ -786,34 +786,34 @@ (defun node-ends-block (node) (declare (type node node)) (let* ((block (node-block node)) - (start (node-next node)) - (last (block-last block))) + (start (node-next node)) + (last (block-last block))) (unless (eq last node) (aver (and (eq (ctran-kind start) :inside-block) (not (block-delete-p block)))) (let* ((succ (block-succ block)) - (new-block - (make-block-key :start start - :component (block-component block) - :succ succ :last last))) - (setf (ctran-kind start) :block-start) + (new-block + (make-block-key :start start + :component (block-component block) + :succ succ :last last))) + (setf (ctran-kind start) :block-start) (setf (ctran-use start) nil) - (setf (block-last block) node) + (setf (block-last block) node) (setf (node-next node) nil) - (dolist (b succ) - (setf (block-pred b) - (cons new-block (remove block (block-pred b))))) - (setf (block-succ block) ()) - (link-blocks block new-block) - (add-to-dfo new-block block) - (setf (component-reanalyze (block-component block)) t) - - (do ((ctran start (node-next (ctran-next ctran)))) - ((not ctran)) - (setf (ctran-block ctran) new-block)) - - (setf (block-type-asserted block) t) - (setf (block-test-modified block) t)))) + (dolist (b succ) + (setf (block-pred b) + (cons new-block (remove block (block-pred b))))) + (setf (block-succ block) ()) + (link-blocks block new-block) + (add-to-dfo new-block block) + (setf (component-reanalyze (block-component block)) t) + + (do ((ctran start (node-next (ctran-next ctran)))) + ((not ctran)) + (setf (ctran-block ctran) new-block)) + + (setf (block-type-asserted block) t) + (setf (block-test-modified block) t)))) (values)) ;;;; deleting stuff @@ -827,18 +827,18 @@ ;; mark the LET for reoptimization, since it may be that we have ;; deleted its last variable. (let* ((fun (lambda-var-home leaf)) - (n (position leaf (lambda-vars fun)))) + (n (position leaf (lambda-vars fun)))) (dolist (ref (leaf-refs fun)) (let* ((lvar (node-lvar ref)) - (dest (and lvar (lvar-dest lvar)))) - (when (and (combination-p dest) - (eq (basic-combination-fun dest) lvar) - (eq (basic-combination-kind dest) :local)) - (let* ((args (basic-combination-args dest)) - (arg (elt args n))) - (reoptimize-lvar arg) - (flush-dest arg) - (setf (elt args n) nil)))))) + (dest (and lvar (lvar-dest lvar)))) + (when (and (combination-p dest) + (eq (basic-combination-fun dest) lvar) + (eq (basic-combination-kind dest) :local)) + (let* ((args (basic-combination-args dest)) + (arg (elt args n))) + (reoptimize-lvar arg) + (flush-dest arg) + (setf (elt args n) nil)))))) ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause ;; too much difficulty, since we can efficiently implement @@ -857,13 +857,13 @@ ;; We only deal with LET variables, marking the corresponding ;; initial value arg as needing to be reoptimized. (when (and (eq (functional-kind fun) :let) - (leaf-refs var)) + (leaf-refs var)) (do ((args (basic-combination-args - (lvar-dest (node-lvar (first (leaf-refs fun))))) - (cdr args)) - (vars (lambda-vars fun) (cdr vars))) - ((eq (car vars) var) - (reoptimize-lvar (car args)))))) + (lvar-dest (node-lvar (first (leaf-refs fun))))) + (cdr args)) + (vars (lambda-vars fun) (cdr vars))) + ((eq (car vars) var) + (reoptimize-lvar (car args)))))) (values)) ;;; Delete a function that has no references. This need only be called @@ -871,7 +871,7 @@ ;;; DELETE-REF will handle the deletion. (defun delete-functional (fun) (aver (and (null (leaf-refs fun)) - (not (functional-entry-fun fun)))) + (not (functional-entry-fun fun)))) (etypecase fun (optional-dispatch (delete-optional-dispatch fun)) (clambda (delete-lambda fun))) @@ -884,7 +884,7 @@ (defun delete-lambda (clambda) (declare (type clambda clambda)) (let ((original-kind (functional-kind clambda)) - (bind (lambda-bind clambda))) + (bind (lambda-bind clambda))) (aver (not (member original-kind '(:deleted :toplevel)))) (aver (not (functional-has-external-references-p clambda))) (aver (or (eq original-kind :zombie) bind)) @@ -957,9 +957,9 @@ ;; point anymore. (when (eq original-kind :external) (let ((fun (functional-entry-fun clambda))) - (setf (functional-entry-fun fun) nil) - (when (optional-dispatch-p fun) - (delete-optional-dispatch fun))))) + (setf (functional-entry-fun fun) nil) + (when (optional-dispatch-p fun) + (delete-optional-dispatch fun))))) (values)) @@ -989,29 +989,29 @@ (setf (functional-kind leaf) :deleted) (flet ((frob (fun) - (unless (eq (functional-kind fun) :deleted) - (aver (eq (functional-kind fun) :optional)) - (setf (functional-kind fun) nil) - (let ((refs (leaf-refs fun))) - (cond ((null refs) - (delete-lambda fun)) - ((null (rest refs)) - (or (maybe-let-convert fun) - (maybe-convert-to-assignment fun))) - (t - (maybe-convert-to-assignment fun))))))) - - (dolist (ep (optional-dispatch-entry-points leaf)) + (unless (eq (functional-kind fun) :deleted) + (aver (eq (functional-kind fun) :optional)) + (setf (functional-kind fun) nil) + (let ((refs (leaf-refs fun))) + (cond ((null refs) + (delete-lambda fun)) + ((null (rest refs)) + (or (maybe-let-convert fun) + (maybe-convert-to-assignment fun))) + (t + (maybe-convert-to-assignment fun))))))) + + (dolist (ep (optional-dispatch-entry-points leaf)) (when (promise-ready-p ep) (frob (force ep)))) - (when (optional-dispatch-more-entry leaf) - (frob (optional-dispatch-more-entry leaf))) - (let ((main (optional-dispatch-main-entry leaf))) + (when (optional-dispatch-more-entry leaf) + (frob (optional-dispatch-more-entry leaf))) + (let ((main (optional-dispatch-main-entry leaf))) (when entry (setf (functional-entry-fun entry) main) (setf (functional-entry-fun main) entry)) - (when (eq (functional-kind main) :optional) - (frob main)))))) + (when (eq (functional-kind main) :optional) + (frob main)))))) (values)) @@ -1021,32 +1021,32 @@ (defun delete-ref (ref) (declare (type ref ref)) (let* ((leaf (ref-leaf ref)) - (refs (delq ref (leaf-refs leaf)))) + (refs (delq ref (leaf-refs leaf)))) (setf (leaf-refs leaf) refs) (cond ((null refs) - (typecase leaf - (lambda-var - (delete-lambda-var leaf)) - (clambda - (ecase (functional-kind leaf) - ((nil :let :mv-let :assignment :escape :cleanup) - (aver (null (functional-entry-fun leaf))) - (delete-lambda leaf)) - (:external - (delete-lambda leaf)) - ((:deleted :zombie :optional)))) - (optional-dispatch - (unless (eq (functional-kind leaf) :deleted) - (delete-optional-dispatch leaf))))) - ((null (rest refs)) - (typecase leaf - (clambda (or (maybe-let-convert leaf) - (maybe-convert-to-assignment leaf))) - (lambda-var (reoptimize-lambda-var leaf)))) - (t - (typecase leaf - (clambda (maybe-convert-to-assignment leaf)))))) + (typecase leaf + (lambda-var + (delete-lambda-var leaf)) + (clambda + (ecase (functional-kind leaf) + ((nil :let :mv-let :assignment :escape :cleanup) + (aver (null (functional-entry-fun leaf))) + (delete-lambda leaf)) + (:external + (delete-lambda leaf)) + ((:deleted :zombie :optional)))) + (optional-dispatch + (unless (eq (functional-kind leaf) :deleted) + (delete-optional-dispatch leaf))))) + ((null (rest refs)) + (typecase leaf + (clambda (or (maybe-let-convert leaf) + (maybe-convert-to-assignment leaf))) + (lambda-var (reoptimize-lambda-var leaf)))) + (t + (typecase leaf + (clambda (maybe-convert-to-assignment leaf)))))) (values)) @@ -1061,7 +1061,7 @@ (flush-lvar-externally-checkable-type lvar) (do-uses (use lvar) (let ((prev (node-prev use))) - (let ((block (ctran-block prev))) + (let ((block (ctran-block prev))) (reoptimize-component (block-component block) t) (setf (block-attributep (block-flags block) flush-p type-asserted type-check) @@ -1200,20 +1200,20 @@ (declare (type clambda fun)) (dolist (var (lambda-vars fun)) (unless (or (leaf-ever-used var) - (lambda-var-ignorep var)) + (lambda-var-ignorep var)) (let ((*compiler-error-context* (lambda-bind fun))) - (unless (policy *compiler-error-context* (= inhibit-warnings 3)) - ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" - ;; requires this to be no more than a STYLE-WARNING. - #-sb-xc-host - (compiler-style-warn "The variable ~S is defined but never used." - (leaf-debug-name var)) - ;; There's no reason to accept this kind of equivocation - ;; when compiling our own code, though. - #+sb-xc-host - (warn "The variable ~S is defined but never used." - (leaf-debug-name var))) - (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN + (unless (policy *compiler-error-context* (= inhibit-warnings 3)) + ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" + ;; requires this to be no more than a STYLE-WARNING. + #-sb-xc-host + (compiler-style-warn "The variable ~S is defined but never used." + (leaf-debug-name var)) + ;; There's no reason to accept this kind of equivocation + ;; when compiling our own code, though. + #+sb-xc-host + (warn "The variable ~S is defined but never used." + (leaf-debug-name var))) + (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN (values)) (defvar *deletion-ignored-objects* '(t nil)) @@ -1226,22 +1226,22 @@ (defun present-in-form (obj form depth) (declare (type (integer 0 20) depth)) (cond ((= depth 20) nil) - ((eq obj form) t) - ((atom form) nil) - (t - (let ((first (car form)) - (depth (1+ depth))) - (if (member first '(quote function)) - nil - (or (and (not (symbolp first)) - (present-in-form obj first depth)) - (do ((l (cdr form) (cdr l)) - (n 0 (1+ n))) - ((or (atom l) (> n 100)) - nil) - (declare (fixnum n)) - (when (present-in-form obj (car l) depth) - (return t))))))))) + ((eq obj form) t) + ((atom form) nil) + (t + (let ((first (car form)) + (depth (1+ depth))) + (if (member first '(quote function)) + nil + (or (and (not (symbolp first)) + (present-in-form obj first depth)) + (do ((l (cdr form) (cdr l)) + (n 0 (1+ n))) + ((or (atom l) (> n 100)) + nil) + (declare (fixnum n)) + (when (present-in-form obj (car l) depth) + (return t))))))))) ;;; This function is called on a block immediately before we delete ;;; it. We check to see whether any of the code about to die appeared @@ -1265,27 +1265,27 @@ (let ((home (block-home-lambda block))) (unless (eq (functional-kind home) :deleted) (do-nodes (node nil block) - (let* ((path (node-source-path node)) - (first (first path))) - (when (or (eq first 'original-source-start) - (and (atom first) - (or (not (symbolp first)) - (let ((pkg (symbol-package first))) - (and pkg - (not (eq pkg (symbol-package :end)))))) - (not (member first *deletion-ignored-objects*)) - (not (typep first '(or fixnum character))) - (every (lambda (x) - (present-in-form first x 0)) - (source-path-forms path)) - (present-in-form first (find-original-source path) - 0))) - (unless (return-p node) - (let ((*compiler-error-context* node)) - (compiler-notify 'code-deletion-note - :format-control "deleting unreachable code" - :format-arguments nil))) - (return)))))) + (let* ((path (node-source-path node)) + (first (first path))) + (when (or (eq first 'original-source-start) + (and (atom first) + (or (not (symbolp first)) + (let ((pkg (symbol-package first))) + (and pkg + (not (eq pkg (symbol-package :end)))))) + (not (member first *deletion-ignored-objects*)) + (not (typep first '(or fixnum character))) + (every (lambda (x) + (present-in-form first x 0)) + (source-path-forms path)) + (present-in-form first (find-original-source path) + 0))) + (unless (return-p node) + (let ((*compiler-error-context* node)) + (compiler-notify 'code-deletion-note + :format-control "deleting unreachable code" + :format-arguments nil))) + (return)))))) (values)) ;;; Delete a node from a block, deleting the block if there are no @@ -1304,57 +1304,57 @@ (delete-lvar-use node)) (let* ((ctran (node-next node)) - (next (and ctran (ctran-next ctran))) - (prev (node-prev node)) - (block (ctran-block prev)) - (prev-kind (ctran-kind prev)) - (last (block-last block))) + (next (and ctran (ctran-next ctran))) + (prev (node-prev node)) + (block (ctran-block prev)) + (prev-kind (ctran-kind prev)) + (last (block-last block))) (setf (block-type-asserted block) t) (setf (block-test-modified block) t) (cond ((or (eq prev-kind :inside-block) - (and (eq prev-kind :block-start) - (not (eq node last)))) - (cond ((eq node last) - (setf (block-last block) (ctran-use prev)) - (setf (node-next (ctran-use prev)) nil)) - (t - (setf (ctran-next prev) next) - (setf (node-prev next) prev) + (and (eq prev-kind :block-start) + (not (eq node last)))) + (cond ((eq node last) + (setf (block-last block) (ctran-use prev)) + (setf (node-next (ctran-use prev)) nil)) + (t + (setf (ctran-next prev) next) + (setf (node-prev next) prev) (when (if-p next) ; AOP wanted (reoptimize-lvar (if-test next))))) - (setf (node-prev node) nil) - nil) - (t - (aver (eq prev-kind :block-start)) - (aver (eq node last)) - (let* ((succ (block-succ block)) - (next (first succ))) - (aver (singleton-p succ)) - (cond - ((eq block (first succ)) - (with-ir1-environment-from-node node - (let ((exit (make-exit))) - (setf (ctran-next prev) nil) - (link-node-to-previous-ctran exit prev) - (setf (block-last block) exit))) - (setf (node-prev node) nil) - nil) - (t - (aver (eq (block-start-cleanup block) - (block-end-cleanup block))) - (unlink-blocks block next) - (dolist (pred (block-pred block)) - (change-block-successor pred block next)) - (when (block-delete-p block) + (setf (node-prev node) nil) + nil) + (t + (aver (eq prev-kind :block-start)) + (aver (eq node last)) + (let* ((succ (block-succ block)) + (next (first succ))) + (aver (singleton-p succ)) + (cond + ((eq block (first succ)) + (with-ir1-environment-from-node node + (let ((exit (make-exit))) + (setf (ctran-next prev) nil) + (link-node-to-previous-ctran exit prev) + (setf (block-last block) exit))) + (setf (node-prev node) nil) + nil) + (t + (aver (eq (block-start-cleanup block) + (block-end-cleanup block))) + (unlink-blocks block next) + (dolist (pred (block-pred block)) + (change-block-successor pred block next)) + (when (block-delete-p block) (let ((component (block-component block))) (setf (component-delete-blocks component) (delq block (component-delete-blocks component))))) (remove-from-dfo block) (setf (block-delete-p block) t) - (setf (node-prev node) nil) - t))))))) + (setf (node-prev node) nil) + t))))))) ;;; Return true if CTRAN has been deleted, false if it is still a valid ;;; part of IR1. @@ -1417,36 +1417,36 @@ to feed directly to the LVAR-DEST of LVAR, which must be a combination." (declare (type lvar lvar) - (type symbol fun) - (type index num-args)) + (type symbol fun) + (type index num-args)) (let ((outside (lvar-dest lvar)) - (inside (lvar-uses lvar))) + (inside (lvar-uses lvar))) (aver (combination-p outside)) (unless (combination-p inside) (give-up-ir1-transform)) (let ((inside-fun (combination-fun inside))) (unless (eq (lvar-fun-name inside-fun) fun) - (give-up-ir1-transform)) + (give-up-ir1-transform)) (let ((inside-args (combination-args inside))) - (unless (= (length inside-args) num-args) - (give-up-ir1-transform)) - (let* ((outside-args (combination-args outside)) - (arg-position (position lvar outside-args)) - (before-args (subseq outside-args 0 arg-position)) - (after-args (subseq outside-args (1+ arg-position)))) - (dolist (arg inside-args) - (setf (lvar-dest arg) outside) + (unless (= (length inside-args) num-args) + (give-up-ir1-transform)) + (let* ((outside-args (combination-args outside)) + (arg-position (position lvar outside-args)) + (before-args (subseq outside-args 0 arg-position)) + (after-args (subseq outside-args (1+ arg-position)))) + (dolist (arg inside-args) + (setf (lvar-dest arg) outside) (flush-lvar-externally-checkable-type arg)) - (setf (combination-args inside) nil) - (setf (combination-args outside) - (append before-args inside-args after-args)) - (change-ref-leaf (lvar-uses inside-fun) - (find-free-fun 'list "???")) - (setf (combination-fun-info inside) (info :function :info 'list) - (combination-kind inside) :known) - (setf (node-derived-type inside) *wild-type*) - (flush-dest lvar) - (values)))))) + (setf (combination-args inside) nil) + (setf (combination-args outside) + (append before-args inside-args after-args)) + (change-ref-leaf (lvar-uses inside-fun) + (find-free-fun 'list "???")) + (setf (combination-fun-info inside) (info :function :info 'list) + (combination-kind inside) :known) + (setf (node-derived-type inside) *wild-type*) + (flush-dest lvar) + (values)))))) (defun flush-combination (combination) (declare (type combination combination)) @@ -1474,8 +1474,8 @@ (and (basic-combination-p dest) (eq lvar (basic-combination-fun dest)) (csubtypep ltype (specifier-type 'function)))) - (setf (node-derived-type ref) vltype) - (derive-node-type ref vltype))) + (setf (node-derived-type ref) vltype) + (derive-node-type ref vltype))) (reoptimize-lvar (node-lvar ref))) (values)) @@ -1500,19 +1500,19 @@ ;;; LEAF and enter it. (defun find-constant (object) (if (typep object - ;; FIXME: What is the significance of this test? ("things - ;; that are worth uniquifying"?) - '(or symbol number character instance)) + ;; FIXME: What is the significance of this test? ("things + ;; that are worth uniquifying"?) + '(or symbol number character instance)) (or (gethash object *constants*) - (setf (gethash object *constants*) - (make-constant :value object - :%source-name '.anonymous. - :type (ctype-of object) - :where-from :defined))) + (setf (gethash object *constants*) + (make-constant :value object + :%source-name '.anonymous. + :type (ctype-of object) + :where-from :defined))) (make-constant :value object - :%source-name '.anonymous. - :type (ctype-of object) - :where-from :defined))) + :%source-name '.anonymous. + :type (ctype-of object) + :where-from :defined))) ;;; Return true if VAR would have to be closed over if environment ;;; analysis ran now (i.e. if there are any uses that have a different @@ -1540,7 +1540,7 @@ (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) (when (and (eq (nlx-info-block nlx) block) (eq (nlx-info-cleanup nlx) cleanup)) - (return nlx))))) + (return nlx))))) (defun nlx-info-lvar (nlx) (declare (type nlx-info nlx)) @@ -1563,17 +1563,17 @@ (defun looks-like-an-mv-bind (functional) (and (optional-dispatch-p functional) (do ((arg (optional-dispatch-arglist functional) (cdr arg))) - ((null arg) nil) - (let ((info (lambda-var-arg-info (car arg)))) - (unless info (return nil)) - (case (arg-info-kind info) - (:optional - (when (or (arg-info-supplied-p info) (arg-info-default info)) - (return nil))) - (:rest - (return (and (null (cdr arg)) (null (leaf-refs (car arg)))))) - (t - (return nil))))))) + ((null arg) nil) + (let ((info (lambda-var-arg-info (car arg)))) + (unless info (return nil)) + (case (arg-info-kind info) + (:optional + (when (or (arg-info-supplied-p info) (arg-info-default info)) + (return nil))) + (:rest + (return (and (null (cdr arg)) (null (leaf-refs (car arg)))))) + (t + (return nil))))))) ;;; Return true if function is an external entry point. This is true ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas @@ -1589,15 +1589,15 @@ (declare (type lvar lvar)) (let ((use (lvar-uses lvar))) (if (ref-p use) - (let ((leaf (ref-leaf use))) - (if (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function) - (or (not (defined-fun-p leaf)) - (not (eq (defined-fun-inlinep leaf) :notinline)) - notinline-ok)) - (leaf-source-name leaf) - nil)) - nil))) + (let ((leaf (ref-leaf use))) + (if (and (global-var-p leaf) + (eq (global-var-kind leaf) :global-function) + (or (not (defined-fun-p leaf)) + (not (eq (defined-fun-inlinep leaf) :notinline)) + notinline-ok)) + (leaf-source-name leaf) + nil)) + nil))) ;;; Return the source name of a combination. (This is an idiom ;;; which was used in CMU CL. I gather it always works. -- WHN) @@ -1617,7 +1617,7 @@ (declare (type lambda-var var)) (let ((fun (lambda-var-home var))) (elt (combination-args (let-combination fun)) - (position-or-lose var (lambda-vars fun))))) + (position-or-lose var (lambda-vars fun))))) ;;; Return the LAMBDA that is called by the local CALL. (defun combination-lambda (call) @@ -1634,28 +1634,28 @@ ;;; limit, and warn if so, returning NIL. (defun inline-expansion-ok (node) (let ((expanded (incf (component-inline-expansions - (block-component - (node-block node)))))) + (block-component + (node-block node)))))) (cond ((> expanded *inline-expansion-limit*) nil) - ((= expanded *inline-expansion-limit*) - ;; FIXME: If the objective is to stop the recursive - ;; expansion of inline functions, wouldn't it be more - ;; correct to look back through surrounding expansions - ;; (which are, I think, stored in the *CURRENT-PATH*, and - ;; possibly stored elsewhere too) and suppress expansion - ;; and print this warning when the function being proposed - ;; for inline expansion is found there? (I don't like the - ;; arbitrary numerical limit in principle, and I think - ;; it'll be a nuisance in practice if we ever want the - ;; compiler to be able to use WITH-COMPILATION-UNIT on - ;; arbitrarily huge blocks of code. -- WHN) - (let ((*compiler-error-context* node)) - (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ + ((= expanded *inline-expansion-limit*) + ;; FIXME: If the objective is to stop the recursive + ;; expansion of inline functions, wouldn't it be more + ;; correct to look back through surrounding expansions + ;; (which are, I think, stored in the *CURRENT-PATH*, and + ;; possibly stored elsewhere too) and suppress expansion + ;; and print this warning when the function being proposed + ;; for inline expansion is found there? (I don't like the + ;; arbitrary numerical limit in principle, and I think + ;; it'll be a nuisance in practice if we ever want the + ;; compiler to be able to use WITH-COMPILATION-UNIT on + ;; arbitrarily huge blocks of code. -- WHN) + (let ((*compiler-error-context* node)) + (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ probably trying to~% ~ inline a recursive function." - *inline-expansion-limit*)) - nil) - (t t)))) + *inline-expansion-limit*)) + nil) + (t t)))) ;;; Make sure that FUNCTIONAL is not let-converted or deleted. (defun assure-functional-live-p (functional) @@ -1676,14 +1676,14 @@ (let ((kind (basic-combination-kind call))) (or (eq kind :full) (and (eq kind :known) - (let ((info (basic-combination-fun-info call))) - (and - (not (fun-info-ir2-convert info)) - (dolist (template (fun-info-templates info) t) - (when (eq (template-ltn-policy template) :fast-safe) - (multiple-value-bind (val win) - (valid-fun-use call (template-type template)) - (when (or val (not win)) (return nil))))))))))) + (let ((info (basic-combination-fun-info call))) + (and + (not (fun-info-ir2-convert info)) + (dolist (template (fun-info-templates info) t) + (when (eq (template-ltn-policy template) :fast-safe) + (multiple-value-bind (val win) + (valid-fun-use call (template-type template)) + (when (or val (not win)) (return nil))))))))))) ;;;; careful call @@ -1694,16 +1694,16 @@ ;;; the error context for any error message, and CONTEXT is a string ;;; that is spliced into the warning. (declaim (ftype (sfunction ((or symbol function) list node function string) - (values list boolean)) - careful-call)) + (values list boolean)) + careful-call)) (defun careful-call (function args node warn-fun context) (values (multiple-value-list (handler-case (apply function args) (error (condition) - (let ((*compiler-error-context* node)) - (funcall warn-fun "Lisp error during ~A:~%~A" context condition) - (return-from careful-call (values nil nil)))))) + (let ((*compiler-error-context* node)) + (funcall warn-fun "Lisp error during ~A:~%~A" context condition) + (return-from careful-call (values nil nil)))))) t)) ;;; Variations of SPECIFIER-TYPE for parsing possibly wrong @@ -1713,8 +1713,8 @@ `(progn (defun ,careful (specifier) (handler-case (,basic specifier) - (sb!kernel::arg-count-error (condition) - (values nil (list (format nil "~A" condition)))) + (sb!kernel::arg-count-error (condition) + (values nil (list (format nil "~A" condition)))) (simple-error (condition) (values nil (list* (simple-condition-format-control condition) (simple-condition-format-arguments condition)))))) @@ -1739,7 +1739,7 @@ ;;; otherwise. The legality and constantness of the keywords should ;;; already have been checked. (declaim (ftype (sfunction (list keyword) (or lvar null)) - find-keyword-lvar)) + find-keyword-lvar)) (defun find-keyword-lvar (args key) (do ((arg args (cddr arg))) ((null arg) nil) @@ -1754,7 +1754,7 @@ (do ((arg args (cddr arg))) ((null arg) t) (unless (and (rest arg) - (constant-lvar-p (first arg))) + (constant-lvar-p (first arg))) (return nil)))) ;;; This function is used by the result of PARSE-DEFTRANSFORM to @@ -1764,9 +1764,9 @@ (defun check-transform-keys (args keys) (and (check-key-args-constant args) (do ((arg args (cddr arg))) - ((null arg) t) - (unless (member (lvar-value (first arg)) keys) - (return nil))))) + ((null arg) t) + (unless (member (lvar-value (first arg)) keys) + (return nil))))) ;;;; miscellaneous @@ -1775,8 +1775,8 @@ (defun %event (info node) (incf (event-info-count info)) (when (and (>= (event-info-level info) *event-note-threshold*) - (policy (or node *lexenv*) - (= inhibit-warnings 0))) + (policy (or node *lexenv*) + (= inhibit-warnings 0))) (let ((*compiler-error-context* node)) (compiler-notify (event-info-description info)))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index d796e12..30041ce 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -27,11 +27,11 @@ (declare (type ctype type)) (multiple-value-bind (check-ptype exact) (primitive-type type) (if exact - (primitive-type-check check-ptype) - (let ((name (hairy-type-check-template-name type))) - (if name - (template-or-lose name) - nil))))) + (primitive-type-check check-ptype) + (let ((name (hairy-type-check-template-name type))) + (if name + (template-or-lose name) + nil))))) ;;; Emit code in BLOCK to check that VALUE is of the specified TYPE, ;;; yielding the checked result in RESULT. VALUE and result may be of @@ -40,7 +40,7 @@ ;;; test. (defun emit-type-check (node block value result type) (declare (type tn value result) (type node node) (type ir2-block block) - (type ctype type)) + (type ctype type)) (emit-move-template node block (type-check-template type) value result) (values)) @@ -60,28 +60,28 @@ ;;; Return the TN that holds the value of THING in the environment ENV. (declaim (ftype (function ((or nlx-info lambda-var clambda) physenv) tn) - find-in-physenv)) + find-in-physenv)) (defun find-in-physenv (thing physenv) (or (cdr (assoc thing (ir2-physenv-closure (physenv-info physenv)))) (etypecase thing - (lambda-var - ;; I think that a failure of this assertion means that we're - ;; trying to access a variable which was improperly closed - ;; over. The PHYSENV describes a physical environment. Every - ;; variable that a form refers to should either be in its - ;; physical environment directly, or grabbed from a - ;; surrounding physical environment when it was closed over. - ;; The ASSOC expression above finds closed-over variables, so - ;; if we fell through the ASSOC expression, it wasn't closed - ;; over. Therefore, it must be in our physical environment - ;; directly. If instead it is in some other physical - ;; environment, then it's bogus for us to reference it here - ;; without it being closed over. -- WHN 2001-09-29 - (aver (eq physenv (lambda-physenv (lambda-var-home thing)))) - (leaf-info thing)) - (nlx-info - (aver (eq physenv (block-physenv (nlx-info-target thing)))) - (ir2-nlx-info-home (nlx-info-info thing))) + (lambda-var + ;; I think that a failure of this assertion means that we're + ;; trying to access a variable which was improperly closed + ;; over. The PHYSENV describes a physical environment. Every + ;; variable that a form refers to should either be in its + ;; physical environment directly, or grabbed from a + ;; surrounding physical environment when it was closed over. + ;; The ASSOC expression above finds closed-over variables, so + ;; if we fell through the ASSOC expression, it wasn't closed + ;; over. Therefore, it must be in our physical environment + ;; directly. If instead it is in some other physical + ;; environment, then it's bogus for us to reference it here + ;; without it being closed over. -- WHN 2001-09-29 + (aver (eq physenv (lambda-physenv (lambda-var-home thing)))) + (leaf-info thing)) + (nlx-info + (aver (eq physenv (block-physenv (nlx-info-target thing)))) + (ir2-nlx-info-home (nlx-info-info thing))) (clambda (aver (xep-p thing)) (entry-info-closure-tn (lambda-info thing)))) @@ -93,7 +93,7 @@ (declare (type constant leaf)) (or (leaf-info leaf) (setf (leaf-info leaf) - (make-constant-tn leaf)))) + (make-constant-tn leaf)))) ;;; Return a TN that represents the value of LEAF, or NIL if LEAF ;;; isn't directly represented by a TN. ENV is the environment that @@ -117,41 +117,41 @@ (defun ir2-convert-ref (node block) (declare (type ref node) (type ir2-block block)) (let* ((lvar (node-lvar node)) - (leaf (ref-leaf node)) - (locs (lvar-result-tns - lvar (list (primitive-type (leaf-type leaf))))) - (res (first locs))) + (leaf (ref-leaf node)) + (locs (lvar-result-tns + lvar (list (primitive-type (leaf-type leaf))))) + (res (first locs))) (etypecase leaf (lambda-var (let ((tn (find-in-physenv leaf (node-physenv node)))) - (if (lambda-var-indirect leaf) - (vop value-cell-ref node block tn res) - (emit-move node block tn res)))) + (if (lambda-var-indirect leaf) + (vop value-cell-ref node block tn res) + (emit-move node block tn res)))) (constant (if (legal-immediate-constant-p leaf) - (emit-move node block (constant-tn leaf) res) - (let* ((name (leaf-source-name leaf)) - (name-tn (emit-constant name))) - (if (policy node (zerop safety)) - (vop fast-symbol-value node block name-tn res) - (vop symbol-value node block name-tn res))))) + (emit-move node block (constant-tn leaf) res) + (let* ((name (leaf-source-name leaf)) + (name-tn (emit-constant name))) + (if (policy node (zerop safety)) + (vop fast-symbol-value node block name-tn res) + (vop symbol-value node block name-tn res))))) (functional (ir2-convert-closure node block leaf res)) (global-var (let ((unsafe (policy node (zerop safety))) - (name (leaf-source-name leaf))) - (ecase (global-var-kind leaf) - ((:special :global) - (aver (symbolp name)) - (let ((name-tn (emit-constant name))) - (if unsafe - (vop fast-symbol-value node block name-tn res) - (vop symbol-value node block name-tn res)))) - (:global-function - (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) - (if unsafe - (vop fdefn-fun node block fdefn-tn res) - (vop safe-fdefn-fun node block fdefn-tn res)))))))) + (name (leaf-source-name leaf))) + (ecase (global-var-kind leaf) + ((:special :global) + (aver (symbolp name)) + (let ((name-tn (emit-constant name))) + (if unsafe + (vop fast-symbol-value node block name-tn res) + (vop symbol-value node block name-tn res)))) + (:global-function + (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) + (if unsafe + (vop fdefn-fun node block fdefn-tn res) + (vop safe-fdefn-fun node block fdefn-tn res)))))))) (move-lvar-result node block locs lvar)) (values)) @@ -161,9 +161,9 @@ ;; sane and easier to understand things if it were *always* true, ;; but experimentally I observe that it's only *almost* always ;; true. -- WHN 2001-01-02 - #+nil + #+nil (aver (eql (lambda-component clambda) - (block-component (ir2-block-block ir2-block)))) + (block-component (ir2-block-block ir2-block)))) ;; Check for some weirdness which came up in bug ;; 138, 2002-01-02. ;; @@ -181,7 +181,7 @@ ;; when it's caught at dump time, so this assertion tries to catch ;; it here. (aver (member clambda - (component-lambdas (lambda-component clambda)))) + (component-lambdas (lambda-component clambda)))) ;; another bug-138-related issue: COMPONENT-NEW-FUNCTIONALS is ;; used as a queue for stuff pending to do in IR1, and now that ;; we're doing IR2 it should've been completely flushed (but @@ -206,26 +206,26 @@ ;;; pre-analyzed the top level code, we just leave an empty slot. (defun ir2-convert-closure (ref ir2-block functional res) (declare (type ref ref) - (type ir2-block ir2-block) - (type functional functional) - (type tn res)) + (type ir2-block ir2-block) + (type functional functional) + (type tn res)) (aver (not (eql (functional-kind functional) :deleted))) (unless (leaf-info functional) (setf (leaf-info functional) - (make-entry-info :name (functional-debug-name functional)))) + (make-entry-info :name (functional-debug-name functional)))) (let ((closure (etypecase functional - (clambda - (assertions-on-ir2-converted-clambda functional) - (physenv-closure (get-lambda-physenv functional))) - (functional - (aver (eq (functional-kind functional) :toplevel-xep)) - nil)))) + (clambda + (assertions-on-ir2-converted-clambda functional) + (physenv-closure (get-lambda-physenv functional))) + (functional + (aver (eq (functional-kind functional) :toplevel-xep)) + nil)))) (cond (closure (let* ((physenv (node-physenv ref)) (tn (find-in-physenv functional physenv))) (emit-move ref ir2-block tn res))) - (t + (t (let ((entry (make-load-time-constant-tn :entry functional))) (emit-move ref ir2-block entry res))))) (values)) @@ -284,24 +284,24 @@ (defun ir2-convert-set (node block) (declare (type cset node) (type ir2-block block)) (let* ((lvar (node-lvar node)) - (leaf (set-var node)) - (val (lvar-tn node block (set-value node))) - (locs (if lvar - (lvar-result-tns - lvar (list (primitive-type (leaf-type leaf)))) - nil))) + (leaf (set-var node)) + (val (lvar-tn node block (set-value node))) + (locs (if lvar + (lvar-result-tns + lvar (list (primitive-type (leaf-type leaf)))) + nil))) (etypecase leaf (lambda-var (when (leaf-refs leaf) - (let ((tn (find-in-physenv leaf (node-physenv node)))) - (if (lambda-var-indirect leaf) - (vop value-cell-set node block tn val) - (emit-move node block val tn))))) + (let ((tn (find-in-physenv leaf (node-physenv node)))) + (if (lambda-var-indirect leaf) + (vop value-cell-set node block tn val) + (emit-move node block val tn))))) (global-var (ecase (global-var-kind leaf) - ((:special :global) - (aver (symbolp (leaf-source-name leaf))) - (vop set node block (emit-constant (leaf-source-name leaf)) val))))) + ((:special :global) + (aver (symbolp (leaf-source-name leaf))) + (vop set node block (emit-constant (leaf-source-name leaf)) val))))) (when locs (emit-move node block val (first locs)) (move-lvar-result node block locs lvar))) @@ -323,21 +323,21 @@ (defun lvar-tn (node block lvar) (declare (type node node) (type ir2-block block) (type lvar lvar)) (let* ((2lvar (lvar-info lvar)) - (lvar-tn - (ecase (ir2-lvar-kind 2lvar) - (:delayed - (let ((ref (lvar-uses lvar))) - (leaf-tn (ref-leaf ref) (node-physenv ref)))) - (:fixed - (aver (= (length (ir2-lvar-locs 2lvar)) 1)) - (first (ir2-lvar-locs 2lvar))))) - (ptype (ir2-lvar-primitive-type 2lvar))) + (lvar-tn + (ecase (ir2-lvar-kind 2lvar) + (:delayed + (let ((ref (lvar-uses lvar))) + (leaf-tn (ref-leaf ref) (node-physenv ref)))) + (:fixed + (aver (= (length (ir2-lvar-locs 2lvar)) 1)) + (first (ir2-lvar-locs 2lvar))))) + (ptype (ir2-lvar-primitive-type 2lvar))) (cond ((eq (tn-primitive-type lvar-tn) ptype) lvar-tn) - (t - (let ((temp (make-normal-tn ptype))) - (emit-move node block lvar-tn temp) - temp))))) + (t + (let ((temp (make-normal-tn ptype))) + (emit-move node block lvar-tn temp) + temp))))) ;;; This is similar to LVAR-TN, but hacks multiple values. We return ;;; TNs holding the values of LVAR with PTYPES as their primitive @@ -349,9 +349,9 @@ ;;; move the extra values with no check. (defun lvar-tns (node block lvar ptypes) (declare (type node node) (type ir2-block block) - (type lvar lvar) (list ptypes)) + (type lvar lvar) (list ptypes)) (let* ((locs (ir2-lvar-locs (lvar-info lvar))) - (nlocs (length locs))) + (nlocs (length locs))) (aver (= nlocs (length ptypes))) (mapcar (lambda (from to-type) @@ -386,29 +386,29 @@ (mapcar #'make-normal-tn types) (let ((2lvar (lvar-info lvar))) (ecase (ir2-lvar-kind 2lvar) - (:fixed - (let* ((locs (ir2-lvar-locs 2lvar)) - (nlocs (length locs)) - (ntypes (length types))) - (if (and (= nlocs ntypes) - (do ((loc locs (cdr loc)) - (type types (cdr type))) - ((null loc) t) - (unless (eq (tn-primitive-type (car loc)) (car type)) - (return nil)))) - locs - (mapcar (lambda (loc type) - (if (eq (tn-primitive-type loc) type) - loc - (make-normal-tn type))) - (if (< nlocs ntypes) - (append locs - (mapcar #'make-normal-tn - (subseq types nlocs))) - locs) - types)))) - (:unknown - (mapcar #'make-normal-tn types)))))) + (:fixed + (let* ((locs (ir2-lvar-locs 2lvar)) + (nlocs (length locs)) + (ntypes (length types))) + (if (and (= nlocs ntypes) + (do ((loc locs (cdr loc)) + (type types (cdr type))) + ((null loc) t) + (unless (eq (tn-primitive-type (car loc)) (car type)) + (return nil)))) + locs + (mapcar (lambda (loc type) + (if (eq (tn-primitive-type loc) type) + loc + (make-normal-tn type))) + (if (< nlocs ntypes) + (append locs + (mapcar #'make-normal-tn + (subseq types nlocs))) + locs) + types)))) + (:unknown + (mapcar #'make-normal-tn types)))))) ;;; Make the first N standard value TNs, returning them in a list. (defun make-standard-value-tns (n) @@ -443,15 +443,15 @@ (defun move-results-coerced (node block src dest) (declare (type node node) (type ir2-block block) (list src dest)) (let ((nsrc (length src)) - (ndest (length dest))) + (ndest (length dest))) (mapc (lambda (from to) - (unless (eq from to) - (emit-move node block from to))) - (if (> ndest nsrc) - (append src (make-list (- ndest nsrc) - :initial-element (emit-constant nil))) - src) - dest)) + (unless (eq from to) + (emit-move node block from to))) + (if (> ndest nsrc) + (append src (make-list (- ndest nsrc) + :initial-element (emit-constant nil))) + src) + dest)) (values)) ;;; Move each SRC TN into the corresponding DEST TN, checking types @@ -459,20 +459,20 @@ (defun move-results-checked (node block src dest types) (declare (type node node) (type ir2-block block) (list src dest types)) (let ((nsrc (length src)) - (ndest (length dest)) + (ndest (length dest)) (ntypes (length types))) (mapc (lambda (from to type) (if type (emit-type-check node block from to type) (emit-move node block from to))) - (if (> ndest nsrc) - (append src (make-list (- ndest nsrc) - :initial-element (emit-constant nil))) - src) - dest + (if (> ndest nsrc) + (append src (make-list (- ndest nsrc) + :initial-element (emit-constant nil))) + src) + dest (if (> ndest ntypes) - (append types (make-list (- ndest ntypes))) - types))) + (append types (make-list (- ndest ntypes))) + types))) (values)) ;;; If necessary, emit coercion code needed to deliver the RESULTS to @@ -487,7 +487,7 @@ ;;; values on the stack. (defun move-lvar-result (node block results lvar) (declare (type node node) (type ir2-block block) - (list results) (type (or lvar null) lvar)) + (list results) (type (or lvar null) lvar)) (when lvar (let ((2lvar (lvar-info lvar))) (ecase (ir2-lvar-kind 2lvar) @@ -544,22 +544,22 @@ ;;; for emitting any necessary type-checking code. (defun reference-args (node block args template) (declare (type node node) (type ir2-block block) (list args) - (type template template)) + (type template template)) (collect ((info-args)) (let ((last nil) - (first nil)) + (first nil)) (do ((args args (cdr args)) - (types (template-arg-types template) (cdr types))) - ((null args)) - (let ((type (first types)) - (arg (first args))) - (if (and (consp type) (eq (car type) ':constant)) - (info-args (lvar-value arg)) - (let ((ref (reference-tn (lvar-tn node block arg) nil))) - (if last - (setf (tn-ref-across last) ref) - (setf first ref)) - (setq last ref))))) + (types (template-arg-types template) (cdr types))) + ((null args)) + (let ((type (first types)) + (arg (first args))) + (if (and (consp type) (eq (car type) ':constant)) + (info-args (lvar-value arg)) + (let ((ref (reference-tn (lvar-tn node block arg) nil))) + (if last + (setf (tn-ref-across last) ref) + (setf first ref)) + (setq last ref))))) (values (the (or tn-ref null) first) (info-args))))) @@ -569,30 +569,30 @@ ;;; negated. (defun ir2-convert-conditional (node block template args info-args if not-p) (declare (type node node) (type ir2-block block) - (type template template) (type (or tn-ref null) args) - (list info-args) (type cif if) (type boolean not-p)) + (type template template) (type (or tn-ref null) args) + (list info-args) (type cif if) (type boolean not-p)) (aver (= (template-info-arg-count template) (+ (length info-args) 2))) (let ((consequent (if-consequent if)) - (alternative (if-alternative if))) + (alternative (if-alternative if))) (cond ((drop-thru-p if consequent) - (emit-template node block template args nil - (list* (block-label alternative) (not not-p) - info-args))) - (t - (emit-template node block template args nil - (list* (block-label consequent) not-p info-args)) - (unless (drop-thru-p if alternative) - (vop branch node block (block-label alternative))))))) + (emit-template node block template args nil + (list* (block-label alternative) (not not-p) + info-args))) + (t + (emit-template node block template args nil + (list* (block-label consequent) not-p info-args)) + (unless (drop-thru-p if alternative) + (vop branch node block (block-label alternative))))))) ;;; Convert an IF that isn't the DEST of a conditional template. (defun ir2-convert-if (node block) (declare (type ir2-block block) (type cif node)) (let* ((test (if-test node)) - (test-ref (reference-tn (lvar-tn node block test) nil)) - (nil-ref (reference-tn (emit-constant nil) nil))) + (test-ref (reference-tn (lvar-tn node block test) nil)) + (nil-ref (reference-tn (emit-constant nil) nil))) (setf (tn-ref-across test-ref) nil-ref) (ir2-convert-conditional node block (template-or-lose 'if-eq) - test-ref () node t))) + test-ref () node t))) ;;; Return a list of primitive-types that we can pass to ;;; LVAR-RESULT-TNS describing the result types we want for a @@ -602,25 +602,25 @@ ;;; restrictions. (defun find-template-result-types (call template rtypes) (declare (type combination call) - (type template template) (list rtypes)) + (type template template) (list rtypes)) (declare (ignore template)) (let* ((dtype (node-derived-type call)) - (type dtype) - (types (mapcar #'primitive-type - (if (values-type-p type) - (append (values-type-required type) - (values-type-optional type)) - (list type))))) + (type dtype) + (types (mapcar #'primitive-type + (if (values-type-p type) + (append (values-type-required type) + (values-type-optional type)) + (list type))))) (let ((nvals (length rtypes)) - (ntypes (length types))) + (ntypes (length types))) (cond ((< ntypes nvals) - (append types - (make-list (- nvals ntypes) - :initial-element *backend-t-primitive-type*))) - ((> ntypes nvals) - (subseq types 0 nvals)) - (t - types))))) + (append types + (make-list (- nvals ntypes) + :initial-element *backend-t-primitive-type*))) + ((> ntypes nvals) + (subseq types 0 nvals)) + (t + types))))) ;;; Return a list of TNs usable in a CALL to TEMPLATE delivering ;;; values to LVAR. As an efficiency hack, we pick off the common case @@ -629,51 +629,51 @@ ;;; values count mismatch. (defun make-template-result-tns (call lvar template rtypes) (declare (type combination call) (type (or lvar null) lvar) - (type template template) (list rtypes)) + (type template template) (list rtypes)) (let ((2lvar (when lvar (lvar-info lvar)))) (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed)) - (let ((locs (ir2-lvar-locs 2lvar))) - (if (and (= (length rtypes) (length locs)) - (do ((loc locs (cdr loc)) - (rtype rtypes (cdr rtype))) - ((null loc) t) - (unless (operand-restriction-ok - (car rtype) - (tn-primitive-type (car loc)) - :t-ok nil) - (return nil)))) - locs - (lvar-result-tns - lvar - (find-template-result-types call template rtypes)))) - (lvar-result-tns - lvar - (find-template-result-types call template rtypes))))) + (let ((locs (ir2-lvar-locs 2lvar))) + (if (and (= (length rtypes) (length locs)) + (do ((loc locs (cdr loc)) + (rtype rtypes (cdr rtype))) + ((null loc) t) + (unless (operand-restriction-ok + (car rtype) + (tn-primitive-type (car loc)) + :t-ok nil) + (return nil)))) + locs + (lvar-result-tns + lvar + (find-template-result-types call template rtypes)))) + (lvar-result-tns + lvar + (find-template-result-types call template rtypes))))) ;;; Get the operands into TNs, make TN-REFs for them, and then call ;;; the template emit function. (defun ir2-convert-template (call block) (declare (type combination call) (type ir2-block block)) (let* ((template (combination-info call)) - (lvar (node-lvar call)) - (rtypes (template-result-types template))) + (lvar (node-lvar call)) + (rtypes (template-result-types template))) (multiple-value-bind (args info-args) - (reference-args call block (combination-args call) template) + (reference-args call block (combination-args call) template) (aver (not (template-more-results-type template))) (if (eq rtypes :conditional) - (ir2-convert-conditional call block template args info-args - (lvar-dest lvar) nil) - (let* ((results (make-template-result-tns call lvar template rtypes)) - (r-refs (reference-tn-list results t))) - (aver (= (length info-args) - (template-info-arg-count template))) + (ir2-convert-conditional call block template args info-args + (lvar-dest lvar) nil) + (let* ((results (make-template-result-tns call lvar template rtypes)) + (r-refs (reference-tn-list results t))) + (aver (= (length info-args) + (template-info-arg-count template))) (when (and lvar (lvar-dynamic-extent lvar)) (vop current-stack-pointer call block (ir2-lvar-stack-pointer (lvar-info lvar)))) - (if info-args - (emit-template call block template args r-refs info-args) - (emit-template call block template args r-refs)) - (move-lvar-result call block results lvar))))) + (if info-args + (emit-template call block template args r-refs info-args) + (emit-template call block template args r-refs)) + (move-lvar-result call block results lvar))))) (values)) ;;; We don't have to do much because operand count checking is done by @@ -682,20 +682,20 @@ ;;; arguments. (defoptimizer (%%primitive ir2-convert) ((template info &rest args) call block) (let* ((template (lvar-value template)) - (info (lvar-value info)) - (lvar (node-lvar call)) - (rtypes (template-result-types template)) - (results (make-template-result-tns call lvar template rtypes)) - (r-refs (reference-tn-list results t))) + (info (lvar-value info)) + (lvar (node-lvar call)) + (rtypes (template-result-types template)) + (results (make-template-result-tns call lvar template rtypes)) + (r-refs (reference-tn-list results t))) (multiple-value-bind (args info-args) - (reference-args call block (cddr (combination-args call)) template) + (reference-args call block (cddr (combination-args call)) template) (aver (not (template-more-results-type template))) (aver (not (eq rtypes :conditional))) (aver (null info-args)) (if info - (emit-template call block template args r-refs info) - (emit-template call block template args r-refs)) + (emit-template call block template args r-refs info) + (emit-template call block template args r-refs)) (move-lvar-result call block results lvar))) (values)) @@ -710,13 +710,13 @@ (defun ir2-convert-let (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) (mapc (lambda (var arg) - (when arg - (let ((src (lvar-tn node block arg)) - (dest (leaf-info var))) - (if (lambda-var-indirect var) - (do-make-value-cell node block src dest) - (emit-move node block src dest))))) - (lambda-vars fun) (basic-combination-args node)) + (when arg + (let ((src (lvar-tn node block arg)) + (dest (leaf-info var))) + (if (lambda-var-indirect var) + (do-make-value-cell node block src dest) + (emit-move node block src dest))))) + (lambda-vars fun) (basic-combination-args node)) (values)) ;;; Emit any necessary moves into assignment temps for a local call to @@ -733,39 +733,39 @@ ;;; environment alone. (defun emit-psetq-moves (node block fun old-fp) (declare (type combination node) (type ir2-block block) (type clambda fun) - (type (or tn null) old-fp)) + (type (or tn null) old-fp)) (let ((actuals (mapcar (lambda (x) - (when x - (lvar-tn node block x))) - (combination-args node)))) + (when x + (lvar-tn node block x))) + (combination-args node)))) (collect ((temps) - (locs)) + (locs)) (dolist (var (lambda-vars fun)) - (let ((actual (pop actuals)) - (loc (leaf-info var))) - (when actual - (cond - ((lambda-var-indirect var) - (let ((temp - (make-normal-tn *backend-t-primitive-type*))) - (do-make-value-cell node block actual temp) - (temps temp))) - ((member actual (locs)) - (let ((temp (make-normal-tn (tn-primitive-type loc)))) - (emit-move node block actual temp) - (temps temp))) - (t - (temps actual))) - (locs loc)))) + (let ((actual (pop actuals)) + (loc (leaf-info var))) + (when actual + (cond + ((lambda-var-indirect var) + (let ((temp + (make-normal-tn *backend-t-primitive-type*))) + (do-make-value-cell node block actual temp) + (temps temp))) + ((member actual (locs)) + (let ((temp (make-normal-tn (tn-primitive-type loc)))) + (emit-move node block actual temp) + (temps temp))) + (t + (temps actual))) + (locs loc)))) (when old-fp - (let ((this-1env (node-physenv node)) - (called-env (physenv-info (lambda-physenv fun)))) - (dolist (thing (ir2-physenv-closure called-env)) - (temps (find-in-physenv (car thing) this-1env)) - (locs (cdr thing))) - (temps old-fp) - (locs (ir2-physenv-old-fp called-env)))) + (let ((this-1env (node-physenv node)) + (called-env (physenv-info (lambda-physenv fun)))) + (dolist (thing (ir2-physenv-closure called-env)) + (temps (find-in-physenv (car thing) this-1env)) + (locs (cdr thing))) + (temps old-fp) + (locs (ir2-physenv-old-fp called-env)))) (values (temps) (locs))))) @@ -777,17 +777,17 @@ (declare (type combination node) (type ir2-block block) (type clambda fun)) (let ((this-env (physenv-info (node-physenv node)))) (multiple-value-bind (temps locs) - (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env)) + (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env)) (mapc (lambda (temp loc) - (emit-move node block temp loc)) - temps locs)) + (emit-move node block temp loc)) + temps locs)) (emit-move node block - (ir2-physenv-return-pc this-env) - (ir2-physenv-return-pc-pass - (physenv-info - (lambda-physenv fun))))) + (ir2-physenv-return-pc this-env) + (ir2-physenv-return-pc-pass + (physenv-info + (lambda-physenv fun))))) (values)) @@ -799,8 +799,8 @@ (multiple-value-bind (temps locs) (emit-psetq-moves node block fun nil) (mapc (lambda (temp loc) - (emit-move node block temp loc)) - temps locs)) + (emit-move node block temp loc)) + temps locs)) (values)) ;;; Do stuff to set up the arguments to a non-tail local call @@ -810,29 +810,29 @@ (defun ir2-convert-local-call-args (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) (let ((fp (make-stack-pointer-tn)) - (nfp (make-number-stack-pointer-tn)) - (old-fp (make-stack-pointer-tn))) + (nfp (make-number-stack-pointer-tn)) + (old-fp (make-stack-pointer-tn))) (multiple-value-bind (temps locs) - (emit-psetq-moves node block fun old-fp) + (emit-psetq-moves node block fun old-fp) (vop current-fp node block old-fp) (vop allocate-frame node block - (physenv-info (lambda-physenv fun)) - fp nfp) + (physenv-info (lambda-physenv fun)) + fp nfp) (values fp nfp temps (mapcar #'make-alias-tn locs))))) ;;; Handle a non-TR known-values local call. We emit the call, then ;;; move the results to the lvar's destination. (defun ir2-convert-local-known-call (node block fun returns lvar start) (declare (type node node) (type ir2-block block) (type clambda fun) - (type return-info returns) (type (or lvar null) lvar) - (type label start)) + (type return-info returns) (type (or lvar null) lvar) + (type label start)) (multiple-value-bind (fp nfp temps arg-locs) (ir2-convert-local-call-args node block fun) (let ((locs (return-info-locations returns))) (vop* known-call-local node block - (fp nfp (reference-tn-list temps nil)) - ((reference-tn-list locs t)) - arg-locs (physenv-info (lambda-physenv fun)) start) + (fp nfp (reference-tn-list temps nil)) + ((reference-tn-list locs t)) + arg-locs (physenv-info (lambda-physenv fun)) start) (move-lvar-result node block locs lvar))) (values)) @@ -848,22 +848,22 @@ ;;; coercions. (defun ir2-convert-local-unknown-call (node block fun lvar start) (declare (type node node) (type ir2-block block) (type clambda fun) - (type (or lvar null) lvar) (type label start)) + (type (or lvar null) lvar) (type label start)) (multiple-value-bind (fp nfp temps arg-locs) (ir2-convert-local-call-args node block fun) (let ((2lvar (and lvar (lvar-info lvar))) - (env (physenv-info (lambda-physenv fun))) - (temp-refs (reference-tn-list temps nil))) + (env (physenv-info (lambda-physenv fun))) + (temp-refs (reference-tn-list temps nil))) (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :unknown)) - (vop* multiple-call-local node block (fp nfp temp-refs) - ((reference-tn-list (ir2-lvar-locs 2lvar) t)) - arg-locs env start) - (let ((locs (standard-result-tns lvar))) - (vop* call-local node block - (fp nfp temp-refs) - ((reference-tn-list locs t)) - arg-locs env start (length locs)) - (move-lvar-result node block locs lvar))))) + (vop* multiple-call-local node block (fp nfp temp-refs) + ((reference-tn-list (ir2-lvar-locs 2lvar) t)) + arg-locs env start) + (let ((locs (standard-result-tns lvar))) + (vop* call-local node block + (fp nfp temp-refs) + ((reference-tn-list locs t)) + arg-locs env start (length locs)) + (move-lvar-result node block locs lvar))))) (values)) ;;; Dispatch to the appropriate function, depending on whether we have @@ -873,25 +873,25 @@ (defun ir2-convert-local-call (node block) (declare (type combination node) (type ir2-block block)) (let* ((fun (ref-leaf (lvar-uses (basic-combination-fun node)))) - (kind (functional-kind fun))) + (kind (functional-kind fun))) (cond ((eq kind :let) - (ir2-convert-let node block fun)) - ((eq kind :assignment) - (ir2-convert-assignment node block fun)) - ((node-tail-p node) - (ir2-convert-tail-local-call node block fun)) - (t - (let ((start (block-label (lambda-block fun))) - (returns (tail-set-info (lambda-tail-set fun))) - (lvar (node-lvar node))) - (ecase (if returns - (return-info-kind returns) - :unknown) - (:unknown - (ir2-convert-local-unknown-call node block fun lvar start)) - (:fixed - (ir2-convert-local-known-call node block fun returns - lvar start))))))) + (ir2-convert-let node block fun)) + ((eq kind :assignment) + (ir2-convert-assignment node block fun)) + ((node-tail-p node) + (ir2-convert-tail-local-call node block fun)) + (t + (let ((start (block-label (lambda-block fun))) + (returns (tail-set-info (lambda-tail-set fun))) + (lvar (node-lvar node))) + (ecase (if returns + (return-info-kind returns) + :unknown) + (:unknown + (ir2-convert-local-unknown-call node block fun lvar start)) + (:fixed + (ir2-convert-local-known-call node block fun returns + lvar start))))))) (values)) ;;;; full call @@ -909,32 +909,32 @@ (declare (type lvar lvar)) (let ((2lvar (lvar-info lvar))) (if (eq (ir2-lvar-kind 2lvar) :delayed) - (let ((name (lvar-fun-name lvar t))) - (aver name) - (values (make-load-time-constant-tn :fdefinition name) t)) - (let* ((locs (ir2-lvar-locs 2lvar)) - (loc (first locs)) - (function-ptype (primitive-type-or-lose 'function))) - (aver (and (eq (ir2-lvar-kind 2lvar) :fixed) - (= (length locs) 1))) + (let ((name (lvar-fun-name lvar t))) + (aver name) + (values (make-load-time-constant-tn :fdefinition name) t)) + (let* ((locs (ir2-lvar-locs 2lvar)) + (loc (first locs)) + (function-ptype (primitive-type-or-lose 'function))) + (aver (and (eq (ir2-lvar-kind 2lvar) :fixed) + (= (length locs) 1))) (aver (eq (tn-primitive-type loc) function-ptype)) - (values loc nil))))) + (values loc nil))))) ;;; Set up the args to NODE in the current frame, and return a TN-REF ;;; list for the passing locations. (defun move-tail-full-call-args (node block) (declare (type combination node) (type ir2-block block)) (let ((args (basic-combination-args node)) - (last nil) - (first nil)) + (last nil) + (first nil)) (dotimes (num (length args)) (let ((loc (standard-arg-location num))) - (emit-move node block (lvar-tn node block (elt args num)) loc) - (let ((ref (reference-tn loc nil))) - (if last - (setf (tn-ref-across last) ref) - (setf first ref)) - (setq last ref)))) + (emit-move node block (lvar-tn node block (elt args num)) loc) + (let ((ref (reference-tn loc nil))) + (if last + (setf (tn-ref-across last) ref) + (setf first ref)) + (setq last ref)))) first)) ;;; Move the arguments into the passing locations and do a (possibly @@ -942,23 +942,23 @@ (defun ir2-convert-tail-full-call (node block) (declare (type combination node) (type ir2-block block)) (let* ((env (physenv-info (node-physenv node))) - (args (basic-combination-args node)) - (nargs (length args)) - (pass-refs (move-tail-full-call-args node block)) - (old-fp (ir2-physenv-old-fp env)) - (return-pc (ir2-physenv-return-pc env))) + (args (basic-combination-args node)) + (nargs (length args)) + (pass-refs (move-tail-full-call-args node block)) + (old-fp (ir2-physenv-old-fp env)) + (return-pc (ir2-physenv-return-pc env))) (multiple-value-bind (fun-tn named) - (fun-lvar-tn node block (basic-combination-fun node)) + (fun-lvar-tn node block (basic-combination-fun node)) (if named - (vop* tail-call-named node block - (fun-tn old-fp return-pc pass-refs) - (nil) - nargs) - (vop* tail-call node block - (fun-tn old-fp return-pc pass-refs) - (nil) - nargs)))) + (vop* tail-call-named node block + (fun-tn old-fp return-pc pass-refs) + (nil) + nargs) + (vop* tail-call node block + (fun-tn old-fp return-pc pass-refs) + (nil) + nargs)))) (values)) @@ -966,22 +966,22 @@ (defun ir2-convert-full-call-args (node block) (declare (type combination node) (type ir2-block block)) (let* ((args (basic-combination-args node)) - (fp (make-stack-pointer-tn)) - (nargs (length args))) + (fp (make-stack-pointer-tn)) + (nargs (length args))) (vop allocate-full-call-frame node block nargs fp) (collect ((locs)) (let ((last nil) - (first nil)) - (dotimes (num nargs) - (locs (standard-arg-location num)) - (let ((ref (reference-tn (lvar-tn node block (elt args num)) - nil))) - (if last - (setf (tn-ref-across last) ref) - (setf first ref)) - (setq last ref))) - - (values fp first (locs) nargs))))) + (first nil)) + (dotimes (num nargs) + (locs (standard-arg-location num)) + (let ((ref (reference-tn (lvar-tn node block (elt args num)) + nil))) + (if last + (setf (tn-ref-across last) ref) + (setf first ref)) + (setq last ref))) + + (values fp first (locs) nargs))))) ;;; Do full call when a fixed number of values are desired. We make ;;; STANDARD-RESULT-TNS for our lvar, then deliver the result using @@ -991,17 +991,17 @@ (multiple-value-bind (fp args arg-locs nargs) (ir2-convert-full-call-args node block) (let* ((lvar (node-lvar node)) - (locs (standard-result-tns lvar)) - (loc-refs (reference-tn-list locs t)) - (nvals (length locs))) + (locs (standard-result-tns lvar)) + (loc-refs (reference-tn-list locs t)) + (nvals (length locs))) (multiple-value-bind (fun-tn named) - (fun-lvar-tn node block (basic-combination-fun node)) - (if named - (vop* call-named node block (fp fun-tn args) (loc-refs) - arg-locs nargs nvals) - (vop* call node block (fp fun-tn args) (loc-refs) - arg-locs nargs nvals)) - (move-lvar-result node block locs lvar)))) + (fun-lvar-tn node block (basic-combination-fun node)) + (if named + (vop* call-named node block (fp fun-tn args) (loc-refs) + arg-locs nargs nvals) + (vop* call node block (fp fun-tn args) (loc-refs) + arg-locs nargs nvals)) + (move-lvar-result node block locs lvar)))) (values)) ;;; Do full call when unknown values are desired. @@ -1010,15 +1010,15 @@ (multiple-value-bind (fp args arg-locs nargs) (ir2-convert-full-call-args node block) (let* ((lvar (node-lvar node)) - (locs (ir2-lvar-locs (lvar-info lvar))) - (loc-refs (reference-tn-list locs t))) + (locs (ir2-lvar-locs (lvar-info lvar))) + (loc-refs (reference-tn-list locs t))) (multiple-value-bind (fun-tn named) - (fun-lvar-tn node block (basic-combination-fun node)) - (if named - (vop* multiple-call-named node block (fp fun-tn args) (loc-refs) - arg-locs nargs) - (vop* multiple-call node block (fp fun-tn args) (loc-refs) - arg-locs nargs))))) + (fun-lvar-tn node block (basic-combination-fun node)) + (if named + (vop* multiple-call-named node block (fp fun-tn args) (loc-refs) + arg-locs nargs) + (vop* multiple-call node block (fp fun-tn args) (loc-refs) + arg-locs nargs))))) (values)) ;;; stuff to check in PONDER-FULL-CALL @@ -1064,22 +1064,22 @@ ;;; a DEFSETF or some such thing elsewhere in the program? (defun ponder-full-call (node) (let* ((lvar (basic-combination-fun node)) - (fname (lvar-fun-name lvar t))) + (fname (lvar-fun-name lvar t))) (declare (type (or symbol cons) fname)) #!+sb-show (unless (gethash fname *full-called-fnames*) - (setf (gethash fname *full-called-fnames*) t)) + (setf (gethash fname *full-called-fnames*) t)) #!+sb-show (when *show-full-called-fnames-p* - (/show "converting full call to named function" fname) - (/show (basic-combination-args node)) - (/show (policy node speed) (policy node safety)) - (/show (policy node compilation-speed)) - (let ((arg-types (mapcar (lambda (lvar) - (when lvar - (type-specifier - (lvar-type lvar)))) - (basic-combination-args node)))) - (/show arg-types))) + (/show "converting full call to named function" fname) + (/show (basic-combination-args node)) + (/show (policy node speed) (policy node safety)) + (/show (policy node compilation-speed)) + (let ((arg-types (mapcar (lambda (lvar) + (when lvar + (type-specifier + (lvar-type lvar)))) + (basic-combination-args node)))) + (/show arg-types))) ;; When illegal code is compiled, all sorts of perverse paths ;; through the compiler can be taken, and it's much harder -- and @@ -1088,15 +1088,15 @@ ;; in that case. (unless *failure-p* (when (memq fname *always-optimized-away*) - (/show (policy node speed) (policy node safety)) - (/show (policy node compilation-speed)) - (bug "full call to ~S" fname))) + (/show (policy node speed) (policy node safety)) + (/show (policy node compilation-speed)) + (bug "full call to ~S" fname))) (when (consp fname) (aver (legal-fun-name-p fname)) (destructuring-bind (setfoid &rest stem) fname - (when (eq setfoid 'setf) - (setf (gethash (car stem) *setf-assumed-fboundp*) t)))))) + (when (eq setfoid 'setf) + (setf (gethash (car stem) *setf-assumed-fboundp*) t)))))) ;;; If the call is in a tail recursive position and the return ;;; convention is standard, then do a tail full call. If one or fewer @@ -1126,42 +1126,42 @@ (defun init-xep-environment (node block fun) (declare (type bind node) (type ir2-block block) (type clambda fun)) (let ((start-label (entry-info-offset (leaf-info fun))) - (env (physenv-info (node-physenv node)))) + (env (physenv-info (node-physenv node)))) (let ((ef (functional-entry-fun fun))) (cond ((and (optional-dispatch-p ef) (optional-dispatch-more-entry ef)) - ;; Special case the xep-allocate-frame + copy-more-arg case. - (vop xep-allocate-frame node block start-label t) - (vop copy-more-arg node block (optional-dispatch-max-args ef))) - (t - ;; No more args, so normal entry. - (vop xep-allocate-frame node block start-label nil))) + ;; Special case the xep-allocate-frame + copy-more-arg case. + (vop xep-allocate-frame node block start-label t) + (vop copy-more-arg node block (optional-dispatch-max-args ef))) + (t + ;; No more args, so normal entry. + (vop xep-allocate-frame node block start-label nil))) (if (ir2-physenv-closure env) - (let ((closure (make-normal-tn *backend-t-primitive-type*))) - (vop setup-closure-environment node block start-label closure) - (when (getf (functional-plist ef) :fin-function) - (vop funcallable-instance-lexenv node block closure closure)) - (let ((n -1)) - (dolist (loc (ir2-physenv-closure env)) - (vop closure-ref node block closure (incf n) (cdr loc))))) - (vop setup-environment node block start-label))) + (let ((closure (make-normal-tn *backend-t-primitive-type*))) + (vop setup-closure-environment node block start-label closure) + (when (getf (functional-plist ef) :fin-function) + (vop funcallable-instance-lexenv node block closure closure)) + (let ((n -1)) + (dolist (loc (ir2-physenv-closure env)) + (vop closure-ref node block closure (incf n) (cdr loc))))) + (vop setup-environment node block start-label))) (unless (eq (functional-kind fun) :toplevel) (let ((vars (lambda-vars fun)) - (n 0)) - (when (leaf-refs (first vars)) - (emit-move node block (make-arg-count-location) - (leaf-info (first vars)))) - (dolist (arg (rest vars)) - (when (leaf-refs arg) - (let ((pass (standard-arg-location n)) - (home (leaf-info arg))) - (if (lambda-var-indirect arg) - (do-make-value-cell node block pass home) - (emit-move node block pass home)))) - (incf n)))) + (n 0)) + (when (leaf-refs (first vars)) + (emit-move node block (make-arg-count-location) + (leaf-info (first vars)))) + (dolist (arg (rest vars)) + (when (leaf-refs arg) + (let ((pass (standard-arg-location n)) + (home (leaf-info arg))) + (if (lambda-var-indirect arg) + (do-make-value-cell node block pass home) + (emit-move node block pass home)))) + (incf n)))) (emit-move node block (make-old-fp-passing-location t) - (ir2-physenv-old-fp env))) + (ir2-physenv-old-fp env))) (values)) @@ -1175,21 +1175,21 @@ (defun ir2-convert-bind (node block) (declare (type bind node) (type ir2-block block)) (let* ((fun (bind-lambda node)) - (env (physenv-info (lambda-physenv fun)))) + (env (physenv-info (lambda-physenv fun)))) (aver (member (functional-kind fun) - '(nil :external :optional :toplevel :cleanup))) + '(nil :external :optional :toplevel :cleanup))) (when (xep-p fun) (init-xep-environment node block fun) #!+sb-dyncount (when *collect-dynamic-statistics* - (vop count-me node block *dynamic-counts-tn* - (block-number (ir2-block-block block))))) + (vop count-me node block *dynamic-counts-tn* + (block-number (ir2-block-block block))))) (emit-move node - block - (ir2-physenv-return-pc-pass env) - (ir2-physenv-return-pc env)) + block + (ir2-physenv-return-pc-pass env) + (ir2-physenv-return-pc env)) (let ((lab (gen-label))) (setf (ir2-physenv-environment-start env) lab) @@ -1209,43 +1209,43 @@ (defun ir2-convert-return (node block) (declare (type creturn node) (type ir2-block block)) (let* ((lvar (return-result node)) - (2lvar (lvar-info lvar)) - (lvar-kind (ir2-lvar-kind 2lvar)) - (fun (return-lambda node)) - (env (physenv-info (lambda-physenv fun))) - (old-fp (ir2-physenv-old-fp env)) - (return-pc (ir2-physenv-return-pc env)) - (returns (tail-set-info (lambda-tail-set fun)))) + (2lvar (lvar-info lvar)) + (lvar-kind (ir2-lvar-kind 2lvar)) + (fun (return-lambda node)) + (env (physenv-info (lambda-physenv fun))) + (old-fp (ir2-physenv-old-fp env)) + (return-pc (ir2-physenv-return-pc env)) + (returns (tail-set-info (lambda-tail-set fun)))) (cond ((and (eq (return-info-kind returns) :fixed) - (not (xep-p fun))) + (not (xep-p fun))) (let ((locs (lvar-tns node block lvar - (return-info-types returns)))) - (vop* known-return node block - (old-fp return-pc (reference-tn-list locs nil)) - (nil) - (return-info-locations returns)))) + (return-info-types returns)))) + (vop* known-return node block + (old-fp return-pc (reference-tn-list locs nil)) + (nil) + (return-info-locations returns)))) ((eq lvar-kind :fixed) (let* ((types (mapcar #'tn-primitive-type (ir2-lvar-locs 2lvar))) - (lvar-locs (lvar-tns node block lvar types)) - (nvals (length lvar-locs)) - (locs (make-standard-value-tns nvals))) - (mapc (lambda (val loc) - (emit-move node block val loc)) - lvar-locs - locs) - (if (= nvals 1) - (vop return-single node block old-fp return-pc (car locs)) - (vop* return node block - (old-fp return-pc (reference-tn-list locs nil)) - (nil) - nvals)))) + (lvar-locs (lvar-tns node block lvar types)) + (nvals (length lvar-locs)) + (locs (make-standard-value-tns nvals))) + (mapc (lambda (val loc) + (emit-move node block val loc)) + lvar-locs + locs) + (if (= nvals 1) + (vop return-single node block old-fp return-pc (car locs)) + (vop* return node block + (old-fp return-pc (reference-tn-list locs nil)) + (nil) + nvals)))) (t (aver (eq lvar-kind :unknown)) (vop* return-multiple node block - (old-fp return-pc - (reference-tn-list (ir2-lvar-locs 2lvar) nil)) - (nil))))) + (old-fp return-pc + (reference-tn-list (ir2-lvar-locs 2lvar) nil)) + (nil))))) (values)) @@ -1270,20 +1270,20 @@ (defun ir2-convert-mv-bind (node block) (declare (type mv-combination node) (type ir2-block block)) (let* ((lvar (first (basic-combination-args node))) - (fun (ref-leaf (lvar-uses (basic-combination-fun node)))) - (vars (lambda-vars fun))) + (fun (ref-leaf (lvar-uses (basic-combination-fun node)))) + (vars (lambda-vars fun))) (aver (eq (functional-kind fun) :mv-let)) (mapc (lambda (src var) - (when (leaf-refs var) - (let ((dest (leaf-info var))) - (if (lambda-var-indirect var) - (do-make-value-cell node block src dest) - (emit-move node block src dest))))) - (lvar-tns node block lvar - (mapcar (lambda (x) - (primitive-type (leaf-type x))) - vars)) - vars)) + (when (leaf-refs var) + (let ((dest (leaf-info var))) + (if (lambda-var-indirect var) + (do-make-value-cell node block src dest) + (emit-move node block src dest))))) + (lvar-tns node block lvar + (mapcar (lambda (x) + (primitive-type (leaf-type x))) + vars)) + vars)) (values)) ;;; Emit the appropriate fixed value, unknown value or tail variant of @@ -1295,30 +1295,30 @@ (declare (type mv-combination node) (type ir2-block block)) (aver (basic-combination-args node)) (let* ((start-lvar (lvar-info (first (basic-combination-args node)))) - (start (first (ir2-lvar-locs start-lvar))) - (tails (and (node-tail-p node) - (lambda-tail-set (node-home-lambda node)))) - (lvar (node-lvar node)) - (2lvar (and lvar (lvar-info lvar)))) + (start (first (ir2-lvar-locs start-lvar))) + (tails (and (node-tail-p node) + (lambda-tail-set (node-home-lambda node)))) + (lvar (node-lvar node)) + (2lvar (and lvar (lvar-info lvar)))) (multiple-value-bind (fun named) - (fun-lvar-tn node block (basic-combination-fun node)) + (fun-lvar-tn node block (basic-combination-fun node)) (aver (and (not named) - (eq (ir2-lvar-kind start-lvar) :unknown))) + (eq (ir2-lvar-kind start-lvar) :unknown))) (cond (tails - (let ((env (physenv-info (node-physenv node)))) - (vop tail-call-variable node block start fun - (ir2-physenv-old-fp env) - (ir2-physenv-return-pc env)))) + (let ((env (physenv-info (node-physenv node)))) + (vop tail-call-variable node block start fun + (ir2-physenv-old-fp env) + (ir2-physenv-return-pc env)))) ((and 2lvar - (eq (ir2-lvar-kind 2lvar) :unknown)) - (vop* multiple-call-variable node block (start fun nil) - ((reference-tn-list (ir2-lvar-locs 2lvar) t)))) + (eq (ir2-lvar-kind 2lvar) :unknown)) + (vop* multiple-call-variable node block (start fun nil) + ((reference-tn-list (ir2-lvar-locs 2lvar) t)))) (t - (let ((locs (standard-result-tns lvar))) - (vop* call-variable node block (start fun nil) - ((reference-tn-list locs t)) (length locs)) - (move-lvar-result node block locs lvar))))))) + (let ((locs (standard-result-tns lvar))) + (vop* call-variable node block (start fun nil) + ((reference-tn-list locs t)) (length locs)) + (move-lvar-result node block locs lvar))))))) ;;; Reset the stack pointer to the start of the specified ;;; unknown-values lvar (discarding it and all values globs on top of @@ -1336,7 +1336,7 @@ lvar))))) (defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved - &rest moved) + &rest moved) node block) (let* ( ;; pointer immediately after the nipped block (after (lvar-value last-nipped)) @@ -1374,8 +1374,8 @@ ;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT. (defoptimizer (values ir2-convert) ((&rest values) node block) (let ((tns (mapcar (lambda (x) - (lvar-tn node block x)) - values))) + (lvar-tn node block x)) + values))) (move-lvar-result node block tns (node-lvar node)))) ;;; In the normal case where unknown values are desired, we use the @@ -1386,7 +1386,7 @@ ;;; optimize this case. (defoptimizer (values-list ir2-convert) ((list) node block) (let* ((lvar (node-lvar node)) - (2lvar (and lvar (lvar-info lvar)))) + (2lvar (and lvar (lvar-info lvar)))) (cond ((and 2lvar (eq (ir2-lvar-kind 2lvar) :unknown)) (let ((locs (ir2-lvar-locs 2lvar))) @@ -1418,7 +1418,7 @@ (defoptimizer (%special-bind ir2-convert) ((var value) node block) (let ((name (leaf-source-name (lvar-value var)))) (vop bind node block (lvar-tn node block value) - (emit-constant name)))) + (emit-constant name)))) (defoptimizer (%special-unbind ir2-convert) ((var) node block) (vop unbind node block)) @@ -1468,10 +1468,10 @@ (vop value-cell-ref node block loc temp) (emit-move node block loc temp)) (if value - (let ((locs (ir2-lvar-locs (lvar-info value)))) - (vop unwind node block temp (first locs) (second locs))) - (let ((0-tn (emit-constant 0))) - (vop unwind node block temp 0-tn 0-tn)))) + (let ((locs (ir2-lvar-locs (lvar-info value)))) + (vop unwind node block temp (first locs) (second locs))) + (let ((0-tn (emit-constant 0))) + (vop unwind node block temp 0-tn 0-tn)))) (values)) @@ -1496,11 +1496,11 @@ (let ((args (basic-combination-args node))) (check-catch-tag-type (first args)) (vop* throw node block - ((lvar-tn node block (first args)) - (reference-tn-list - (ir2-lvar-locs (lvar-info (second args))) - nil)) - (nil))) + ((lvar-tn node block (first args)) + (reference-tn-list + (ir2-lvar-locs (lvar-info (second args))) + nil)) + (nil))) (move-lvar-result node block () (node-lvar node)) (values)) @@ -1510,26 +1510,26 @@ ;;; responsible for building a return-PC object. (defun emit-nlx-start (node block info tag) (declare (type node node) (type ir2-block block) (type nlx-info info) - (type (or lvar null) tag)) + (type (or lvar null) tag)) (let* ((2info (nlx-info-info info)) - (kind (cleanup-kind (nlx-info-cleanup info))) - (block-tn (physenv-live-tn - (make-normal-tn (primitive-type-or-lose 'catch-block)) - (node-physenv node))) - (res (make-stack-pointer-tn)) - (target-label (ir2-nlx-info-target 2info))) + (kind (cleanup-kind (nlx-info-cleanup info))) + (block-tn (physenv-live-tn + (make-normal-tn (primitive-type-or-lose 'catch-block)) + (node-physenv node))) + (res (make-stack-pointer-tn)) + (target-label (ir2-nlx-info-target 2info))) (vop current-binding-pointer node block - (car (ir2-nlx-info-dynamic-state 2info))) + (car (ir2-nlx-info-dynamic-state 2info))) (vop* save-dynamic-state node block - (nil) - ((reference-tn-list (cdr (ir2-nlx-info-dynamic-state 2info)) t))) + (nil) + ((reference-tn-list (cdr (ir2-nlx-info-dynamic-state 2info)) t))) (vop current-stack-pointer node block (ir2-nlx-info-save-sp 2info)) (ecase kind (:catch (vop make-catch-block node block block-tn - (lvar-tn node block tag) target-label res)) + (lvar-tn node block tag) target-label res)) ((:unwind-protect :block :tagbody) (vop make-unwind-block node block block-tn target-label res))) @@ -1586,12 +1586,12 @@ ;;; pointer alone, since the thrown values are still out there. (defoptimizer (%nlx-entry ir2-convert) ((info-lvar) node block) (let* ((info (lvar-value info-lvar)) - (lvar (node-lvar node)) - (2info (nlx-info-info info)) - (top-loc (ir2-nlx-info-save-sp 2info)) - (start-loc (make-nlx-entry-arg-start-location)) - (count-loc (make-arg-count-location)) - (target (ir2-nlx-info-target 2info))) + (lvar (node-lvar node)) + (2info (nlx-info-info info)) + (top-loc (ir2-nlx-info-save-sp 2info)) + (start-loc (make-nlx-entry-arg-start-location)) + (count-loc (make-arg-count-location)) + (target (ir2-nlx-info-target 2info))) (ecase (cleanup-kind (nlx-info-cleanup info)) ((:catch :block :tagbody) @@ -1610,38 +1610,38 @@ (move-lvar-result node block locs lvar))))) (:unwind-protect (let ((block-loc (standard-arg-location 0))) - (vop uwp-entry node block target block-loc start-loc count-loc) - (move-lvar-result - node block - (list block-loc start-loc count-loc) - lvar)))) + (vop uwp-entry node block target block-loc start-loc count-loc) + (move-lvar-result + node block + (list block-loc start-loc count-loc) + lvar)))) #!+sb-dyncount (when *collect-dynamic-statistics* (vop count-me node block *dynamic-counts-tn* - (block-number (ir2-block-block block)))) + (block-number (ir2-block-block block)))) (vop* restore-dynamic-state node block - ((reference-tn-list (cdr (ir2-nlx-info-dynamic-state 2info)) nil)) - (nil)) + ((reference-tn-list (cdr (ir2-nlx-info-dynamic-state 2info)) nil)) + (nil)) (vop unbind-to-here node block - (car (ir2-nlx-info-dynamic-state 2info))))) + (car (ir2-nlx-info-dynamic-state 2info))))) ;;;; n-argument functions (macrolet ((def (name) - `(defoptimizer (,name ir2-convert) ((&rest args) node block) - (let* ((refs (move-tail-full-call-args node block)) - (lvar (node-lvar node)) - (res (lvar-result-tns - lvar - (list (primitive-type (specifier-type 'list)))))) + `(defoptimizer (,name ir2-convert) ((&rest args) node block) + (let* ((refs (move-tail-full-call-args node block)) + (lvar (node-lvar node)) + (res (lvar-result-tns + lvar + (list (primitive-type (specifier-type 'list)))))) (when (and lvar (lvar-dynamic-extent lvar)) (vop current-stack-pointer node block (ir2-lvar-stack-pointer (lvar-info lvar)))) - (vop* ,name node block (refs) ((first res) nil) - (length args)) - (move-lvar-result node block res lvar))))) + (vop* ,name node block (refs) ((first res) nil) + (length args)) + (move-lvar-result node block res lvar))))) (def list) (def list*)) @@ -1650,44 +1650,44 @@ (defun ir2-convert (component) (declare (type component component)) (let (#!+sb-dyncount - (*dynamic-counts-tn* - (when *collect-dynamic-statistics* - (let* ((blocks - (block-number (block-next (component-head component)))) - (counts (make-array blocks - :element-type '(unsigned-byte 32) - :initial-element 0)) - (info (make-dyncount-info - :for (component-name component) - :costs (make-array blocks - :element-type '(unsigned-byte 32) - :initial-element 0) - :counts counts))) - (setf (ir2-component-dyncount-info (component-info component)) - info) - (emit-constant info) - (emit-constant counts))))) + (*dynamic-counts-tn* + (when *collect-dynamic-statistics* + (let* ((blocks + (block-number (block-next (component-head component)))) + (counts (make-array blocks + :element-type '(unsigned-byte 32) + :initial-element 0)) + (info (make-dyncount-info + :for (component-name component) + :costs (make-array blocks + :element-type '(unsigned-byte 32) + :initial-element 0) + :counts counts))) + (setf (ir2-component-dyncount-info (component-info component)) + info) + (emit-constant info) + (emit-constant counts))))) (let ((num 0)) (declare (type index num)) (do-ir2-blocks (2block component) - (let ((block (ir2-block-block 2block))) - (when (block-start block) - (setf (block-number block) num) - #!+sb-dyncount - (when *collect-dynamic-statistics* - (let ((first-node (block-start-node block))) - (unless (or (and (bind-p first-node) - (xep-p (bind-lambda first-node))) - (eq (lvar-fun-name - (node-lvar first-node)) - '%nlx-entry)) - (vop count-me - first-node - 2block - #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil - num)))) - (ir2-convert-block block) - (incf num)))))) + (let ((block (ir2-block-block 2block))) + (when (block-start block) + (setf (block-number block) num) + #!+sb-dyncount + (when *collect-dynamic-statistics* + (let ((first-node (block-start-node block))) + (unless (or (and (bind-p first-node) + (xep-p (bind-lambda first-node))) + (eq (lvar-fun-name + (node-lvar first-node)) + '%nlx-entry)) + (vop count-me + first-node + 2block + #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil + num)))) + (ir2-convert-block block) + (incf num)))))) (values)) ;;; If necessary, emit a terminal unconditional branch to go to the @@ -1698,31 +1698,31 @@ (defun finish-ir2-block (block) (declare (type cblock block)) (let* ((2block (block-info block)) - (last (block-last block)) - (succ (block-succ block))) + (last (block-last block)) + (succ (block-succ block))) (unless (if-p last) (aver (singleton-p succ)) (let ((target (first succ))) - (cond ((eq target (component-tail (block-component block))) - (when (and (basic-combination-p last) - (eq (basic-combination-kind last) :full)) - (let* ((fun (basic-combination-fun last)) - (use (lvar-uses fun)) - (name (and (ref-p use) - (leaf-has-source-name-p (ref-leaf use)) - (leaf-source-name (ref-leaf use))))) - (unless (or (node-tail-p last) - (info :function :info name) - (policy last (zerop safety))) - (vop nil-fun-returned-error last 2block - (if name - (emit-constant name) - (multiple-value-bind (tn named) - (fun-lvar-tn last 2block fun) - (aver (not named)) - tn))))))) - ((not (eq (ir2-block-next 2block) (block-info target))) - (vop branch last 2block (block-label target))))))) + (cond ((eq target (component-tail (block-component block))) + (when (and (basic-combination-p last) + (eq (basic-combination-kind last) :full)) + (let* ((fun (basic-combination-fun last)) + (use (lvar-uses fun)) + (name (and (ref-p use) + (leaf-has-source-name-p (ref-leaf use)) + (leaf-source-name (ref-leaf use))))) + (unless (or (node-tail-p last) + (info :function :info name) + (policy last (zerop safety))) + (vop nil-fun-returned-error last 2block + (if name + (emit-constant name) + (multiple-value-bind (tn named) + (fun-lvar-tn last 2block fun) + (aver (not named)) + tn))))))) + ((not (eq (ir2-block-next 2block) (block-info target))) + (vop branch last 2block (block-label target))))))) (values)) @@ -1732,43 +1732,43 @@ (let ((2block (block-info block))) (do-nodes (node lvar block) (etypecase node - (ref + (ref (when lvar (let ((2lvar (lvar-info lvar))) ;; function REF in a local call is not annotated (when (and 2lvar (not (eq (ir2-lvar-kind 2lvar) :delayed))) (ir2-convert-ref node 2block))))) - (combination - (let ((kind (basic-combination-kind node))) - (ecase kind - (:local - (ir2-convert-local-call node 2block)) - (:full - (ir2-convert-full-call node 2block)) - (:known - (let* ((info (basic-combination-fun-info node)) - (fun (fun-info-ir2-convert info))) - (cond (fun - (funcall fun node 2block)) - ((eq (basic-combination-info node) :full) - (ir2-convert-full-call node 2block)) - (t - (ir2-convert-template node 2block)))))))) - (cif - (when (lvar-info (if-test node)) - (ir2-convert-if node 2block))) - (bind - (let ((fun (bind-lambda node))) - (when (eq (lambda-home fun) fun) - (ir2-convert-bind node 2block)))) - (creturn - (ir2-convert-return node 2block)) - (cset - (ir2-convert-set node 2block)) + (combination + (let ((kind (basic-combination-kind node))) + (ecase kind + (:local + (ir2-convert-local-call node 2block)) + (:full + (ir2-convert-full-call node 2block)) + (:known + (let* ((info (basic-combination-fun-info node)) + (fun (fun-info-ir2-convert info))) + (cond (fun + (funcall fun node 2block)) + ((eq (basic-combination-info node) :full) + (ir2-convert-full-call node 2block)) + (t + (ir2-convert-template node 2block)))))))) + (cif + (when (lvar-info (if-test node)) + (ir2-convert-if node 2block))) + (bind + (let ((fun (bind-lambda node))) + (when (eq (lambda-home fun) fun) + (ir2-convert-bind node 2block)))) + (creturn + (ir2-convert-return node 2block)) + (cset + (ir2-convert-set node 2block)) (cast (ir2-convert-cast node 2block)) - (mv-combination - (cond + (mv-combination + (cond ((eq (basic-combination-kind node) :local) (ir2-convert-mv-bind node 2block)) ((eq (lvar-fun-name (basic-combination-fun node)) @@ -1776,11 +1776,11 @@ (ir2-convert-throw node 2block)) (t (ir2-convert-mv-call node 2block)))) - (exit - (when (exit-entry node) - (ir2-convert-exit node 2block))) - (entry - (ir2-convert-entry node 2block))))) + (exit + (when (exit-entry node) + (ir2-convert-exit node 2block))) + (entry + (ir2-convert-entry node 2block))))) (finish-ir2-block block) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index ec49454..8347fe5 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -157,18 +157,18 @@ ;;; Grab the FUN-INFO and enter the function, replacing any old ;;; one with the same type and note. (declaim (ftype (function (t list function &optional (or string null) - (member t nil)) - *) - %deftransform)) + (member t nil)) + *) + %deftransform)) (defun %deftransform (name type fun &optional note important) (let* ((ctype (specifier-type type)) - (note (or note "optimize")) - (info (fun-info-or-lose name)) - (old (find-if (lambda (x) - (and (type= (transform-type x) ctype) - (string-equal (transform-note x) note) - (eq (transform-important x) important))) - (fun-info-transforms info)))) + (note (or note "optimize")) + (info (fun-info-or-lose name)) + (old (find-if (lambda (x) + (and (type= (transform-type x) ctype) + (string-equal (transform-note x) note) + (eq (transform-important x) important))) + (fun-info-transforms info)))) (cond (old (style-warn "Overwriting ~S" old) (setf (transform-function old) fun @@ -182,31 +182,31 @@ ;;; Make a FUN-INFO structure with the specified type, attributes ;;; and optimizers. (declaim (ftype (function (list list attributes &key - (:derive-type (or function null)) - (:optimizer (or function null))) - *) - %defknown)) + (:derive-type (or function null)) + (:optimizer (or function null))) + *) + %defknown)) (defun %defknown (names type attributes &key derive-type optimizer) (let ((ctype (specifier-type type)) - (info (make-fun-info :attributes attributes + (info (make-fun-info :attributes attributes :derive-type derive-type :optimizer optimizer)) - (target-env *info-environment*)) + (target-env *info-environment*)) (dolist (name names) (let ((old-fun-info (info :function :info name))) - (when old-fun-info - ;; This is handled as an error because it's generally a bad - ;; thing to blow away all the old optimization stuff. It's - ;; also a potential source of sneaky bugs: - ;; DEFKNOWN FOO - ;; DEFTRANSFORM FOO - ;; DEFKNOWN FOO ; possibly hidden inside some macroexpansion - ;; ; Now the DEFTRANSFORM doesn't exist in the target Lisp. - ;; However, it's continuable because it might be useful to do - ;; it when testing new optimization stuff interactively. - (cerror "Go ahead, overwrite it." - "~@" - old-fun-info name))) + (when old-fun-info + ;; This is handled as an error because it's generally a bad + ;; thing to blow away all the old optimization stuff. It's + ;; also a potential source of sneaky bugs: + ;; DEFKNOWN FOO + ;; DEFTRANSFORM FOO + ;; DEFKNOWN FOO ; possibly hidden inside some macroexpansion + ;; ; Now the DEFTRANSFORM doesn't exist in the target Lisp. + ;; However, it's continuable because it might be useful to do + ;; it when testing new optimization stuff interactively. + (cerror "Go ahead, overwrite it." + "~@" + old-fun-info name))) (setf (info :function :type name target-env) ctype) (setf (info :function :where-from name target-env) :declared) (setf (info :function :kind name target-env) :function) @@ -221,11 +221,11 @@ (declaim (ftype (sfunction (t) fun-info) fun-info-or-lose)) (defun fun-info-or-lose (name) (let (;; FIXME: Do we need this rebinding here? It's a literal - ;; translation of the old CMU CL rebinding to - ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*), - ;; and it's not obvious whether the rebinding to itself is - ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. - (*info-environment* *info-environment*)) + ;; translation of the old CMU CL rebinding to + ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*), + ;; and it's not obvious whether the rebinding to itself is + ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*. + (*info-environment* *info-environment*)) (let ((old (info :function :info name))) (unless old (error "~S is not a known function." name)) (setf (info :function :info name) (copy-fun-info old))))) @@ -249,8 +249,8 @@ (defun result-type-float-contagion (call) (declare (type combination call)) (reduce #'numeric-contagion (combination-args call) - :key #'lvar-type - :initial-value (specifier-type 'single-float))) + :key #'lvar-type + :initial-value (specifier-type 'single-float))) ;;; Return a closure usable as a derive-type method for accessing the ;;; N'th argument. If arg is a list, result is a list. If arg is a @@ -260,13 +260,13 @@ (declare (type combination call)) (let ((lvar (nth (1- n) (combination-args call)))) (when lvar - (let ((type (lvar-type lvar))) - (if (array-type-p type) - (specifier-type - `(vector ,(type-specifier (array-type-element-type type)))) - (let ((ltype (specifier-type 'list))) - (when (csubtypep type ltype) - ltype)))))))) + (let ((type (lvar-type lvar))) + (if (array-type-p type) + (specifier-type + `(vector ,(type-specifier (array-type-element-type type)))) + (let ((ltype (specifier-type 'list))) + (when (csubtypep type ltype) + ltype)))))))) ;;; Derive the type to be the type specifier which is the Nth arg. (defun result-type-specifier-nth-arg (n) @@ -274,7 +274,7 @@ (declare (type combination call)) (let ((lvar (nth (1- n) (combination-args call)))) (when (and lvar (constant-lvar-p lvar)) - (careful-specifier-type (lvar-value lvar)))))) + (careful-specifier-type (lvar-value lvar)))))) ;;; Derive the type to be the type specifier which is the Nth arg, ;;; with the additional restriptions noted in the CLHS for STRING and @@ -285,35 +285,35 @@ (declare (type combination call)) (let ((lvar (nth (1- n) (combination-args call)))) (when (and lvar (constant-lvar-p lvar)) - (let* ((specifier (lvar-value lvar)) - (lspecifier (if (atom specifier) (list specifier) specifier))) - (cond - ((eq (car lspecifier) 'string) - (destructuring-bind (string &rest size) - lspecifier - (declare (ignore string)) - (careful-specifier-type - `(vector character ,@(when size size))))) - ((eq (car lspecifier) 'simple-string) - (destructuring-bind (simple-string &rest size) - lspecifier - (declare (ignore simple-string)) - (careful-specifier-type - `(simple-array character ,@(if size (list size) '((*))))))) - (t - (let ((ctype (careful-specifier-type specifier))) - (if (and (array-type-p ctype) - (eq (array-type-specialized-element-type ctype) - *wild-type*)) - ;; I don't think I'm allowed to modify what I get - ;; back from SPECIFIER-TYPE; it is, after all, - ;; cached. Better copy it, then. - (let ((real-ctype (copy-structure ctype))) - (setf (array-type-element-type real-ctype) - *universal-type* - (array-type-specialized-element-type real-ctype) - *universal-type*) - real-ctype) - ctype))))))))) + (let* ((specifier (lvar-value lvar)) + (lspecifier (if (atom specifier) (list specifier) specifier))) + (cond + ((eq (car lspecifier) 'string) + (destructuring-bind (string &rest size) + lspecifier + (declare (ignore string)) + (careful-specifier-type + `(vector character ,@(when size size))))) + ((eq (car lspecifier) 'simple-string) + (destructuring-bind (simple-string &rest size) + lspecifier + (declare (ignore simple-string)) + (careful-specifier-type + `(simple-array character ,@(if size (list size) '((*))))))) + (t + (let ((ctype (careful-specifier-type specifier))) + (if (and (array-type-p ctype) + (eq (array-type-specialized-element-type ctype) + *wild-type*)) + ;; I don't think I'm allowed to modify what I get + ;; back from SPECIFIER-TYPE; it is, after all, + ;; cached. Better copy it, then. + (let ((real-ctype (copy-structure ctype))) + (setf (array-type-element-type real-ctype) + *universal-type* + (array-type-specialized-element-type real-ctype) + *universal-type*) + real-ctype) + ctype))))))))) (/show0 "knownfun.lisp end of file") diff --git a/src/compiler/late-macros.lisp b/src/compiler/late-macros.lisp index b467e68..d738330 100644 --- a/src/compiler/late-macros.lisp +++ b/src/compiler/late-macros.lisp @@ -24,22 +24,22 @@ (when (cdr stores) (error "multiple store variables for ~S" place)) (let ((n-item (gensym)) - (n-place (gensym)) - (n-current (gensym)) - (n-prev (gensym))) + (n-place (gensym)) + (n-current (gensym)) + (n-prev (gensym))) `(let* (,@(mapcar #'list temps vals) - (,n-place ,access) - (,n-item ,item)) - (if (eq ,n-place ,n-item) - (let ((,(first stores) (,next ,n-place))) - ,store) - (do ((,n-prev ,n-place ,n-current) - (,n-current (,next ,n-place) - (,next ,n-current))) - ((eq ,n-current ,n-item) - (setf (,next ,n-prev) - (,next ,n-current))))) - (values))))) + (,n-place ,access) + (,n-item ,item)) + (if (eq ,n-place ,n-item) + (let ((,(first stores) (,next ,n-place))) + ,store) + (do ((,n-prev ,n-place ,n-current) + (,n-current (,next ,n-place) + (,next ,n-current))) + ((eq ,n-current ,n-item) + (setf (,next ,n-prev) + (,next ,n-current))))) + (values))))) ;;; Push ITEM onto a list linked by the accessor function NEXT that is ;;; stored in PLACE. @@ -50,7 +50,7 @@ (when (cdr stores) (error "multiple store variables for ~S" place)) `(let (,@(mapcar #'list temps vals) - (,(first stores) ,item)) + (,(first stores) ,item)) (setf (,next ,(first stores)) ,access) ,store (values)))) @@ -58,9 +58,9 @@ ;;; the target-code case of setting boolean attributes #+sb-xc-host (defmacro-mundanely !def-boolean-attribute-setter (test-name - translations-name - &rest attribute-names) + translations-name + &rest attribute-names) (guts-of-!def-boolean-attribute-setter test-name - translations-name - attribute-names - 'sb!xc:get-setf-expansion)) + translations-name + attribute-names + 'sb!xc:get-setf-expansion)) diff --git a/src/compiler/late-vmdef.lisp b/src/compiler/late-vmdef.lisp index 6cf9fd2..708ec0e 100644 --- a/src/compiler/late-vmdef.lisp +++ b/src/compiler/late-vmdef.lisp @@ -31,6 +31,6 @@ it." (let ((loc (note-debug-location vop nil kind))) (sb!assem:emit-postit (lambda (segment posn) - (declare (ignore segment)) - (setf (location-info-label loc) posn)))) + (declare (ignore segment)) + (setf (location-info-label loc) posn)))) (values)) diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 5eba1fa..2e6dba6 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -15,13 +15,13 @@ ;;; (This is also what shows up as an ENVIRONMENT value in macroexpansion.) #!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place (def!struct (lexenv - (:print-function print-lexenv) - (:constructor make-null-lexenv ()) - (:constructor internal-make-lexenv - (funs vars blocks tags + (:print-function print-lexenv) + (:constructor make-null-lexenv ()) + (:constructor internal-make-lexenv + (funs vars blocks tags type-restrictions - lambda cleanup handled-conditions - disabled-package-locks policy))) + lambda cleanup handled-conditions + disabled-package-locks policy))) ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a ;; local function), a DEFINED-FUN, representing an ;; INLINE/NOTINLINE declaration, or a list (MACRO . ) (a @@ -76,7 +76,7 @@ (defun print-lexenv (lexenv stream level) (if (null-lexenv-p lexenv) (print-unreadable-object (lexenv stream) - (write-string "NULL-LEXENV" stream)) + (write-string "NULL-LEXENV" stream)) (default-structure-print lexenv stream level))) (defun maybe-inline-syntactic-closure (lambda lexenv) @@ -94,66 +94,66 @@ ;; unfriendly foreign lisp environments, would be good to support in ;; the target compiler. -- CSR, 2002-05-13 and 2002-11-02 (let ((vars (lexenv-vars lexenv)) - (funs (lexenv-funs lexenv))) + (funs (lexenv-funs lexenv))) (collect ((decls) (macros) (symbol-macros)) (cond - ((or (lexenv-blocks lexenv) (lexenv-tags lexenv)) nil) - ((and (null vars) (null funs)) `(lambda-with-lexenv - nil nil nil - ,@(cdr lambda))) - ((dolist (x vars nil) - #+sb-xc-host - ;; KLUDGE: too complicated for cross-compilation - (return t) - #-sb-xc-host - (let ((name (car x)) - (what (cdr x))) - ;; only worry about the innermost binding - (when (eq x (assoc name vars :test #'eq)) - (typecase what - (cons - (aver (eq (car what) 'macro)) - (symbol-macros x)) - (global-var - ;; A global should not appear in the lexical - ;; environment? Is this true? FIXME! - (aver (eq (global-var-kind what) :special)) - (decls `(special ,name))) - (t - ;; we can't inline in the presence of this object - (return t)))))) - nil) - ((dolist (x funs nil) - #+sb-xc-host - ;; KLUDGE: too complicated for cross-compilation (and - ;; failure of OAOO in comments, *sigh*) - (return t) - #-sb-xc-host - (let ((name (car x)) - (what (cdr x))) - ;; again, only worry about the innermost binding, but - ;; functions can have name (SETF FOO) so we need to use - ;; EQUAL for the test. - (when (eq x (assoc name funs :test #'equal)) - (typecase what - (cons - (macros (cons name (function-lambda-expression (cdr what))))) - ;; FIXME: Is there a good reason for this not to be - ;; DEFINED-FUN (which :INCLUDEs GLOBAL-VAR, in case - ;; you're wondering how this ever worked :-)? Maybe - ;; in conjunction with an AVERrance that it's not an - ;; (AND GLOBAL-VAR (NOT GLOBAL-FUN))? -- CSR, - ;; 2002-07-08 - (global-var - (when (defined-fun-p what) - (decls `(,(car (rassoc (defined-fun-inlinep what) - *inlinep-translations*)) + ((or (lexenv-blocks lexenv) (lexenv-tags lexenv)) nil) + ((and (null vars) (null funs)) `(lambda-with-lexenv + nil nil nil + ,@(cdr lambda))) + ((dolist (x vars nil) + #+sb-xc-host + ;; KLUDGE: too complicated for cross-compilation + (return t) + #-sb-xc-host + (let ((name (car x)) + (what (cdr x))) + ;; only worry about the innermost binding + (when (eq x (assoc name vars :test #'eq)) + (typecase what + (cons + (aver (eq (car what) 'macro)) + (symbol-macros x)) + (global-var + ;; A global should not appear in the lexical + ;; environment? Is this true? FIXME! + (aver (eq (global-var-kind what) :special)) + (decls `(special ,name))) + (t + ;; we can't inline in the presence of this object + (return t)))))) + nil) + ((dolist (x funs nil) + #+sb-xc-host + ;; KLUDGE: too complicated for cross-compilation (and + ;; failure of OAOO in comments, *sigh*) + (return t) + #-sb-xc-host + (let ((name (car x)) + (what (cdr x))) + ;; again, only worry about the innermost binding, but + ;; functions can have name (SETF FOO) so we need to use + ;; EQUAL for the test. + (when (eq x (assoc name funs :test #'equal)) + (typecase what + (cons + (macros (cons name (function-lambda-expression (cdr what))))) + ;; FIXME: Is there a good reason for this not to be + ;; DEFINED-FUN (which :INCLUDEs GLOBAL-VAR, in case + ;; you're wondering how this ever worked :-)? Maybe + ;; in conjunction with an AVERrance that it's not an + ;; (AND GLOBAL-VAR (NOT GLOBAL-FUN))? -- CSR, + ;; 2002-07-08 + (global-var + (when (defined-fun-p what) + (decls `(,(car (rassoc (defined-fun-inlinep what) + *inlinep-translations*)) ,name)))) - (t (return t)))))) - nil) - (t - ;; if we get this far, we've successfully dealt with - ;; everything in FUNS and VARS, so: - `(lambda-with-lexenv ,(decls) ,(macros) ,(symbol-macros) - ,@(cdr lambda))))))) + (t (return t)))))) + nil) + (t + ;; if we get this far, we've successfully dealt with + ;; everything in FUNS and VARS, so: + `(lambda-with-lexenv ,(decls) ,(macros) ,(symbol-macros) + ,@(cdr lambda))))))) diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp index 6aecbcc..6502bc2 100644 --- a/src/compiler/life.lisp +++ b/src/compiler/life.lisp @@ -22,17 +22,17 @@ ;;; block in order to keep that thread sorted. (defun add-global-conflict (kind tn block number) (declare (type (member :read :write :read-only :live) kind) - (type tn tn) (type ir2-block block) - (type (or local-tn-number null) number)) + (type tn tn) (type ir2-block block) + (type (or local-tn-number null) number)) (let ((new (make-global-conflicts kind tn block number))) (let ((last (tn-current-conflict tn))) (if last - (shiftf (global-conflicts-next-tnwise new) - (global-conflicts-next-tnwise last) - new) - (shiftf (global-conflicts-next-tnwise new) - (tn-global-conflicts tn) - new))) + (shiftf (global-conflicts-next-tnwise new) + (global-conflicts-next-tnwise last) + new) + (shiftf (global-conflicts-next-tnwise new) + (tn-global-conflicts tn) + new))) (setf (tn-current-conflict tn) new) (insert-block-global-conflict new block)) @@ -43,14 +43,14 @@ (defun insert-block-global-conflict (new block) (let ((global-num (tn-number (global-conflicts-tn new)))) (do ((prev nil conf) - (conf (ir2-block-global-tns block) - (global-conflicts-next-blockwise conf))) - ((or (null conf) - (> (tn-number (global-conflicts-tn conf)) global-num)) - (if prev - (setf (global-conflicts-next-blockwise prev) new) - (setf (ir2-block-global-tns block) new)) - (setf (global-conflicts-next-blockwise new) conf)))) + (conf (ir2-block-global-tns block) + (global-conflicts-next-blockwise conf))) + ((or (null conf) + (> (tn-number (global-conflicts-tn conf)) global-num)) + (if prev + (setf (global-conflicts-next-blockwise prev) new) + (setf (ir2-block-global-tns block) new)) + (setf (global-conflicts-next-blockwise new) conf)))) (values)) ;;; Reset the CURRENT-CONFLICT slot in all packed TNs to point to the @@ -68,13 +68,13 @@ (defun convert-to-global (tn) (declare (type tn tn)) (let ((block (tn-local tn)) - (num (tn-local-number tn))) + (num (tn-local-number tn))) (add-global-conflict (if (zerop (sbit (ir2-block-written block) num)) - :read-only - (if (zerop (sbit (ir2-block-live-out block) num)) - :write - :read)) + :read-only + (if (zerop (sbit (ir2-block-live-out block) num)) + :write + :read)) tn block num)) (values)) @@ -105,35 +105,35 @@ (defun find-local-references (block) (declare (type ir2-block block)) (let ((kill (ir2-block-written block)) - (live (ir2-block-live-out block)) - (tns (ir2-block-local-tns block))) + (live (ir2-block-live-out block)) + (tns (ir2-block-local-tns block))) (let ((ltn-num (ir2-block-local-tn-count block))) (do ((vop (ir2-block-last-vop block) - (vop-prev vop))) - ((null vop)) - (do ((ref (vop-refs vop) (tn-ref-next-ref ref))) - ((null ref)) - (let* ((tn (tn-ref-tn ref)) - (local (tn-local tn)) - (kind (tn-kind tn))) - (unless (member kind '(:component :environment :constant)) - (unless (eq local block) - (when (= ltn-num local-tn-limit) - (return-from find-local-references vop)) - (when local - (unless (tn-global-conflicts tn) - (convert-to-global tn)) - (add-global-conflict :read-only tn block ltn-num)) - - (setf (tn-local tn) block) - (setf (tn-local-number tn) ltn-num) - (setf (svref tns ltn-num) tn) - (incf ltn-num)) - - (let ((num (tn-local-number tn))) - (if (tn-ref-write-p ref) - (setf (sbit kill num) 1 (sbit live num) 0) - (setf (sbit live num) 1))))))) + (vop-prev vop))) + ((null vop)) + (do ((ref (vop-refs vop) (tn-ref-next-ref ref))) + ((null ref)) + (let* ((tn (tn-ref-tn ref)) + (local (tn-local tn)) + (kind (tn-kind tn))) + (unless (member kind '(:component :environment :constant)) + (unless (eq local block) + (when (= ltn-num local-tn-limit) + (return-from find-local-references vop)) + (when local + (unless (tn-global-conflicts tn) + (convert-to-global tn)) + (add-global-conflict :read-only tn block ltn-num)) + + (setf (tn-local tn) block) + (setf (tn-local-number tn) ltn-num) + (setf (svref tns ltn-num) tn) + (incf ltn-num)) + + (let ((num (tn-local-number tn))) + (if (tn-ref-write-p ref) + (setf (sbit kill num) 1 (sbit live num) 0) + (setf (sbit live num) 1))))))) (setf (ir2-block-local-tn-count block) ltn-num))) nil) @@ -158,22 +158,22 @@ (let ((live (ir2-block-live-out block))) (let ((kill (ir2-block-written block))) (do ((conf (ir2-block-global-tns block) - (global-conflicts-next-blockwise conf))) - ((null conf)) - (let ((num (global-conflicts-number conf))) - (unless (zerop (sbit kill num)) - (setf (global-conflicts-kind conf) - (if (zerop (sbit live num)) - :write - :read)))))) + (global-conflicts-next-blockwise conf))) + ((null conf)) + (let ((num (global-conflicts-number conf))) + (unless (zerop (sbit kill num)) + (setf (global-conflicts-kind conf) + (if (zerop (sbit live num)) + :write + :read)))))) (let ((ltns (ir2-block-local-tns block))) (dotimes (i (ir2-block-local-tn-count block)) - (let ((tn (svref ltns i))) - (unless (or (eq tn :more) - (tn-global-conflicts tn) - (zerop (sbit live i))) - (convert-to-global tn)))))) + (let ((tn (svref ltns i))) + (unless (or (eq tn :more) + (tn-global-conflicts tn) + (zerop (sbit live i))) + (convert-to-global tn)))))) (values)) @@ -185,15 +185,15 @@ ;;; block. (defun split-ir2-blocks (2block lose number) (declare (type ir2-block 2block) (type vop lose) - (type unsigned-byte number)) + (type unsigned-byte number)) (event split-ir2-block (vop-node lose)) (let ((new (make-ir2-block (ir2-block-block 2block))) - (new-start (vop-next lose))) + (new-start (vop-next lose))) (setf (ir2-block-number new) number) (add-to-emit-order new 2block) (do ((vop new-start (vop-next vop))) - ((null vop)) + ((null vop)) (setf (vop-block vop) new)) (setf (ir2-block-start-vop new) new-start) @@ -227,31 +227,31 @@ (setf (ir2-block-local-tn-count block) 0) (do ((conf (ir2-block-global-tns block) - (global-conflicts-next-blockwise conf))) + (global-conflicts-next-blockwise conf))) ((null conf) (setf (ir2-block-global-tns block) nil)) (let ((tn (global-conflicts-tn conf))) (aver (eq (tn-current-conflict tn) conf)) (aver (null (global-conflicts-next-tnwise conf))) (do ((current (tn-global-conflicts tn) - (global-conflicts-next-tnwise current)) - (prev nil current)) - ((eq current conf) - (if prev - (setf (global-conflicts-next-tnwise prev) nil) - (setf (tn-global-conflicts tn) nil)) - (setf (tn-current-conflict tn) prev))))) + (global-conflicts-next-tnwise current)) + (prev nil current)) + ((eq current conf) + (if prev + (setf (global-conflicts-next-tnwise prev) nil) + (setf (tn-global-conflicts tn) nil)) + (setf (tn-current-conflict tn) prev))))) (fill (ir2-block-written block) 0) (let ((ltns (ir2-block-local-tns block))) (dotimes (i local-tn-limit) (let ((tn (svref ltns i))) - (aver (not (eq tn :more))) - (let ((conf (tn-global-conflicts tn))) - (setf (tn-local tn) - (if conf - (global-conflicts-block conf) - nil)))))) + (aver (not (eq tn :more))) + (let ((conf (tn-global-conflicts tn))) + (setf (tn-local tn) + (if conf + (global-conflicts-block conf) + nil)))))) (values)) @@ -290,28 +290,28 @@ (setf (svref (ir2-block-local-tns block) num) :more) (do ((op (do ((op ops (tn-ref-across op)) - (i 0 (1+ i))) - ((= i (length fixed)) op) - (declare (type index i))) - (tn-ref-across op))) - ((null op)) + (i 0 (1+ i))) + ((= i (length fixed)) op) + (declare (type index i))) + (tn-ref-across op))) + ((null op)) (let ((tn (tn-ref-tn op))) - (assert - (flet ((frob (refs) - (do ((ref refs (tn-ref-next ref))) - ((null ref) t) - (when (and (eq (vop-block (tn-ref-vop ref)) block) - (not (eq ref op))) - (return nil))))) - (and (frob (tn-reads tn)) (frob (tn-writes tn)))) - () "More operand ~S used more than once in its VOP." op) - (aver (not (find-in #'global-conflicts-next-blockwise tn - (ir2-block-global-tns block) - :key #'global-conflicts-tn))) - - (add-global-conflict :read-only tn block num) - (setf (tn-local tn) block) - (setf (tn-local-number tn) num)))) + (assert + (flet ((frob (refs) + (do ((ref refs (tn-ref-next ref))) + ((null ref) t) + (when (and (eq (vop-block (tn-ref-vop ref)) block) + (not (eq ref op))) + (return nil))))) + (and (frob (tn-reads tn)) (frob (tn-writes tn)))) + () "More operand ~S used more than once in its VOP." op) + (aver (not (find-in #'global-conflicts-next-blockwise tn + (ir2-block-global-tns block) + :key #'global-conflicts-tn))) + + (add-global-conflict :read-only tn block num) + (setf (tn-local tn) block) + (setf (tn-local-number tn) num)))) (values)) (defevent coalesce-more-ltn-numbers @@ -343,38 +343,38 @@ (declare (type fixnum counter)) (do-blocks-backwards (block component) (let ((2block (block-info block))) - (do ((lose (find-local-references 2block) - (find-local-references 2block)) - (last-lose nil lose) - (coalesced nil)) - ((not lose) - (init-global-conflict-kind 2block) - (setf (ir2-block-number 2block) (incf counter))) - - (clear-lifetime-info 2block) - - (cond - ((vop-next lose) - (aver (not (eq last-lose lose))) - (let ((new (split-ir2-blocks 2block lose (incf counter)))) - (aver (not (find-local-references new))) - (init-global-conflict-kind new))) - (t - (aver (not (eq lose coalesced))) - (setq coalesced lose) - (event coalesce-more-ltn-numbers (vop-node lose)) - (let ((info (vop-info lose)) - (new (if (vop-prev lose) - (split-ir2-blocks 2block (vop-prev lose) - (incf counter)) - 2block))) - (coalesce-more-ltn-numbers new (vop-args lose) - (vop-info-arg-types info)) - (coalesce-more-ltn-numbers new (vop-results lose) - (vop-info-result-types info)) - (let ((lose (find-local-references new))) - (aver (not lose))) - (init-global-conflict-kind new)))))))) + (do ((lose (find-local-references 2block) + (find-local-references 2block)) + (last-lose nil lose) + (coalesced nil)) + ((not lose) + (init-global-conflict-kind 2block) + (setf (ir2-block-number 2block) (incf counter))) + + (clear-lifetime-info 2block) + + (cond + ((vop-next lose) + (aver (not (eq last-lose lose))) + (let ((new (split-ir2-blocks 2block lose (incf counter)))) + (aver (not (find-local-references new))) + (init-global-conflict-kind new))) + (t + (aver (not (eq lose coalesced))) + (setq coalesced lose) + (event coalesce-more-ltn-numbers (vop-node lose)) + (let ((info (vop-info lose)) + (new (if (vop-prev lose) + (split-ir2-blocks 2block (vop-prev lose) + (incf counter)) + 2block))) + (coalesce-more-ltn-numbers new (vop-args lose) + (vop-info-arg-types info)) + (coalesce-more-ltn-numbers new (vop-results lose) + (vop-info-result-types info)) + (let ((lose (find-local-references new))) + (aver (not lose))) + (init-global-conflict-kind new)))))))) (values)) @@ -387,21 +387,21 @@ (declare (type tn tn) (type ir2-block 2block)) (let ((block-num (ir2-block-number 2block))) (do ((conf (tn-current-conflict tn) (global-conflicts-next-tnwise conf)) - (prev nil conf)) - ((or (null conf) - (> (ir2-block-number (global-conflicts-block conf)) block-num)) - (setf (tn-current-conflict tn) prev) - (add-global-conflict :live tn 2block nil)) + (prev nil conf)) + ((or (null conf) + (> (ir2-block-number (global-conflicts-block conf)) block-num)) + (setf (tn-current-conflict tn) prev) + (add-global-conflict :live tn 2block nil)) (when (eq (global-conflicts-block conf) 2block) - (unless (or debug-p - (eq (global-conflicts-kind conf) :live)) - (setf (global-conflicts-kind conf) :live) - (setf (svref (ir2-block-local-tns 2block) - (global-conflicts-number conf)) - nil) - (setf (global-conflicts-number conf) nil)) - (setf (tn-current-conflict tn) conf) - (return)))) + (unless (or debug-p + (eq (global-conflicts-kind conf) :live)) + (setf (global-conflicts-kind conf) :live) + (setf (svref (ir2-block-local-tns 2block) + (global-conflicts-number conf)) + nil) + (setf (global-conflicts-number conf) nil)) + (setf (tn-current-conflict tn) conf) + (return)))) (values)) ;;; Iterate over all the blocks in ENV, setting up :LIVE conflicts for @@ -410,20 +410,20 @@ (defun setup-environment-tn-conflicts (component tn env debug-p) (declare (type component component) (type tn tn) (type physenv env)) (when (and debug-p - (not (tn-global-conflicts tn)) - (tn-local tn)) + (not (tn-global-conflicts tn)) + (tn-local tn)) (convert-to-global tn)) (setf (tn-current-conflict tn) (tn-global-conflicts tn)) (do-blocks-backwards (block component) (when (eq (block-physenv block) env) (let* ((2block (block-info block)) - (last (do ((b (ir2-block-next 2block) (ir2-block-next b)) - (prev 2block b)) - ((not (eq (ir2-block-block b) block)) - prev)))) - (do ((b last (ir2-block-prev b))) - ((not (eq (ir2-block-block b) block))) - (setup-environment-tn-conflict tn b debug-p))))) + (last (do ((b (ir2-block-next 2block) (ir2-block-next b)) + (prev 2block b)) + ((not (eq (ir2-block-block b) block)) + prev)))) + (do ((b last (ir2-block-prev b))) + ((not (eq (ir2-block-block b) block))) + (setup-environment-tn-conflict tn b debug-p))))) (values)) ;;; Iterate over all the environment TNs, adding always-live conflicts @@ -432,11 +432,11 @@ (declare (type component component)) (dolist (fun (component-lambdas component)) (let* ((env (lambda-physenv fun)) - (2env (physenv-info env))) + (2env (physenv-info env))) (dolist (tn (ir2-physenv-live-tns 2env)) - (setup-environment-tn-conflicts component tn env nil)) + (setup-environment-tn-conflicts component tn env nil)) (dolist (tn (ir2-physenv-debug-live-tns 2env)) - (setup-environment-tn-conflicts component tn env t)))) + (setup-environment-tn-conflicts component tn env t)))) (values)) ;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN. @@ -488,38 +488,38 @@ (defun propagate-live-tns (block1 block2) (declare (type ir2-block block1 block2)) (let ((live-in (ir2-block-live-in block1)) - (did-something nil)) + (did-something nil)) (do ((conf2 (ir2-block-global-tns block2) - (global-conflicts-next-blockwise conf2))) - ((null conf2)) + (global-conflicts-next-blockwise conf2))) + ((null conf2)) (ecase (global-conflicts-kind conf2) - ((:live :read :read-only) - (let* ((tn (global-conflicts-tn conf2)) - (tn-conflicts (tn-current-conflict tn)) - (number1 (ir2-block-number block1))) - (aver tn-conflicts) - (do ((current tn-conflicts (global-conflicts-next-tnwise current)) - (prev nil current)) - ((or (null current) - (> (ir2-block-number (global-conflicts-block current)) - number1)) - (setf (tn-current-conflict tn) prev) - (add-global-conflict :live tn block1 nil) - (setq did-something t)) - (when (eq (global-conflicts-block current) block1) - (case (global-conflicts-kind current) - (:live) - (:read-only - (setf (global-conflicts-kind current) :live) - (setf (svref (ir2-block-local-tns block1) - (global-conflicts-number current)) - nil) - (setf (global-conflicts-number current) nil) - (setf (tn-current-conflict tn) current)) - (t - (setf (sbit live-in (global-conflicts-number current)) 1))) - (return))))) - (:write))) + ((:live :read :read-only) + (let* ((tn (global-conflicts-tn conf2)) + (tn-conflicts (tn-current-conflict tn)) + (number1 (ir2-block-number block1))) + (aver tn-conflicts) + (do ((current tn-conflicts (global-conflicts-next-tnwise current)) + (prev nil current)) + ((or (null current) + (> (ir2-block-number (global-conflicts-block current)) + number1)) + (setf (tn-current-conflict tn) prev) + (add-global-conflict :live tn block1 nil) + (setq did-something t)) + (when (eq (global-conflicts-block current) block1) + (case (global-conflicts-kind current) + (:live) + (:read-only + (setf (global-conflicts-kind current) :live) + (setf (svref (ir2-block-local-tns block1) + (global-conflicts-number current)) + nil) + (setf (global-conflicts-number current) nil) + (setf (tn-current-conflict tn) current)) + (t + (setf (sbit live-in (global-conflicts-number current)) 1))) + (return))))) + (:write))) did-something)) ;;; Do backward global flow analysis to find all TNs live at each @@ -529,22 +529,22 @@ (reset-current-conflict component) (let ((did-something nil)) (do-blocks-backwards (block component) - (let* ((2block (block-info block)) - (last (do ((b (ir2-block-next 2block) (ir2-block-next b)) - (prev 2block b)) - ((not (eq (ir2-block-block b) block)) - prev)))) - - (dolist (b (block-succ block)) - (when (and (block-start b) - (propagate-live-tns last (block-info b))) - (setq did-something t))) - - (do ((b (ir2-block-prev last) (ir2-block-prev b)) - (prev last b)) - ((not (eq (ir2-block-block b) block))) - (when (propagate-live-tns b prev) - (setq did-something t))))) + (let* ((2block (block-info block)) + (last (do ((b (ir2-block-next 2block) (ir2-block-next b)) + (prev 2block b)) + ((not (eq (ir2-block-block b) block)) + prev)))) + + (dolist (b (block-succ block)) + (when (and (block-start b) + (propagate-live-tns last (block-info b))) + (setq did-something t))) + + (do ((b (ir2-block-prev last) (ir2-block-prev b)) + (prev last b)) + ((not (eq (ir2-block-block b) block))) + (when (propagate-live-tns b prev) + (setq did-something t))))) (unless did-something (return)))) @@ -557,8 +557,8 @@ ;;; number in the conflicts of all TNs in LIVE-LIST. (defun note-conflicts (live-bits live-list tn num) (declare (type tn tn) (type (or tn null) live-list) - (type local-tn-bit-vector live-bits) - (type local-tn-number num)) + (type local-tn-bit-vector live-bits) + (type local-tn-number num)) (let ((lconf (tn-local-conflicts tn))) (bit-ior live-bits lconf lconf)) (do ((live live-list (tn-next* live))) @@ -571,12 +571,12 @@ (declare (type vop vop) (type local-tn-bit-vector live-bits)) (let ((live (bit-vector-copy live-bits))) (do ((r (vop-results vop) (tn-ref-across r))) - ((null r)) + ((null r)) (let ((tn (tn-ref-tn r))) - (ecase (tn-kind tn) - ((:normal :debug-environment) - (setf (sbit live (tn-local-number tn)) 0)) - (:environment :component)))) + (ecase (tn-kind tn) + ((:normal :debug-environment) + (setf (sbit live (tn-local-number tn)) 0)) + (:environment :component)))) live)) ;;; This is used to determine whether a :DEBUG-ENVIRONMENT TN should @@ -599,27 +599,27 @@ ;;; well. (defun make-debug-environment-tns-live (block live-bits live-list) (let* ((1block (ir2-block-block block)) - (live-in (ir2-block-live-in block)) - (succ (block-succ 1block)) - (next (ir2-block-next block))) + (live-in (ir2-block-live-in block)) + (succ (block-succ 1block)) + (next (ir2-block-next block))) (when (and next - (not (eq (ir2-block-block next) 1block)) - (or (null succ) - (eq (first succ) - (component-tail (block-component 1block))))) + (not (eq (ir2-block-block next) 1block)) + (or (null succ) + (eq (first succ) + (component-tail (block-component 1block))))) (do ((conf (ir2-block-global-tns block) - (global-conflicts-next-blockwise conf))) - ((null conf)) - (let* ((tn (global-conflicts-tn conf)) - (num (global-conflicts-number conf))) - (when (and num (zerop (sbit live-bits num)) - (eq (tn-kind tn) :debug-environment) - (eq (tn-physenv tn) (block-physenv 1block)) - (saved-after-read tn block)) - (note-conflicts live-bits live-list tn num) - (setf (sbit live-bits num) 1) - (push-in tn-next* tn live-list) - (setf (sbit live-in num) 1)))))) + (global-conflicts-next-blockwise conf))) + ((null conf)) + (let* ((tn (global-conflicts-tn conf)) + (num (global-conflicts-number conf))) + (when (and num (zerop (sbit live-bits num)) + (eq (tn-kind tn) :debug-environment) + (eq (tn-physenv tn) (block-physenv 1block)) + (saved-after-read tn block)) + (note-conflicts live-bits live-list tn num) + (setf (sbit live-bits num) 1) + (push-in tn-next* tn live-list) + (setf (sbit live-in num) 1)))))) (values live-bits live-list)) @@ -643,31 +643,31 @@ (defun compute-initial-conflicts (block) (declare (type ir2-block block)) (let* ((live-in (ir2-block-live-in block)) - (ltns (ir2-block-local-tns block)) - (live-bits (bit-vector-copy live-in)) - (live-list nil)) + (ltns (ir2-block-local-tns block)) + (live-bits (bit-vector-copy live-in)) + (live-list nil)) (do ((conf (ir2-block-global-tns block) - (global-conflicts-next-blockwise conf))) - ((null conf)) + (global-conflicts-next-blockwise conf))) + ((null conf)) (let ((bits (global-conflicts-conflicts conf)) - (tn (global-conflicts-tn conf)) - (num (global-conflicts-number conf)) - (kind (global-conflicts-kind conf))) - (setf (tn-local-number tn) num) - (unless (eq kind :live) - (cond ((not (zerop (sbit live-bits num))) - (bit-vector-replace bits live-bits) - (setf (sbit bits num) 0) - (push-in tn-next* tn live-list)) - ((and (eq (svref ltns num) :more) - (eq kind :write)) - (note-conflicts live-bits live-list tn num) - (setf (sbit live-bits num) 1) - (push-in tn-next* tn live-list) - (setf (sbit live-in num) 1))) - - (setf (tn-local-conflicts tn) bits)))) + (tn (global-conflicts-tn conf)) + (num (global-conflicts-number conf)) + (kind (global-conflicts-kind conf))) + (setf (tn-local-number tn) num) + (unless (eq kind :live) + (cond ((not (zerop (sbit live-bits num))) + (bit-vector-replace bits live-bits) + (setf (sbit bits num) 0) + (push-in tn-next* tn live-list)) + ((and (eq (svref ltns num) :more) + (eq kind :write)) + (note-conflicts live-bits live-list tn num) + (setf (sbit live-bits num) 1) + (push-in tn-next* tn live-list) + (setf (sbit live-in num) 1))) + + (setf (tn-local-conflicts tn) bits)))) (make-debug-environment-tns-live block live-bits live-list))) @@ -676,17 +676,17 @@ ;;; force all the live TNs to be stack environment TNs. (defun conflictize-save-p-vop (vop block live-bits) (declare (type vop vop) (type ir2-block block) - (type local-tn-bit-vector live-bits)) + (type local-tn-bit-vector live-bits)) (let ((ss (compute-save-set vop live-bits))) (setf (vop-save-set vop) ss) (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack) (do-live-tns (tn ss block) - (unless (eq (tn-kind tn) :component) - (force-tn-to-stack tn) - (unless (eq (tn-kind tn) :environment) - (convert-to-environment-tn - tn - (block-physenv (ir2-block-block block)))))))) + (unless (eq (tn-kind tn) :component) + (force-tn-to-stack tn) + (unless (eq (tn-kind tn) :environment) + (convert-to-environment-tn + tn + (block-physenv (ir2-block-block block)))))))) (values)) ;;; FIXME: The next 3 macros aren't needed in the target runtime. @@ -707,12 +707,12 @@ `(when (eq (svref ltns num) :more) (let ((prev ref)) (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref))) - ((null mref)) - (let ((mtn (tn-ref-tn mref))) - (unless (eql (tn-local-number mtn) num) - (return)) - ,action) - (setq prev mref)) + ((null mref)) + (let ((mtn (tn-ref-tn mref))) + (unless (eql (tn-local-number mtn) num) + (return)) + ,action) + (setq prev mref)) (setq ref prev)))) ;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs @@ -722,21 +722,21 @@ '(do ((ref (vop-refs vop) (tn-ref-next-ref ref))) ((null ref)) (let* ((tn (tn-ref-tn ref)) - (num (tn-local-number tn))) + (num (tn-local-number tn))) (cond - ((not num)) - ((not (zerop (sbit live-bits num))) - (when (tn-ref-write-p ref) - (setf (sbit live-bits num) 0) - (deletef-in tn-next* live-list tn) - (frob-more-tns (deletef-in tn-next* live-list mtn)))) - (t - (aver (not (tn-ref-write-p ref))) - (note-conflicts live-bits live-list tn num) - (frob-more-tns (note-conflicts live-bits live-list mtn num)) - (setf (sbit live-bits num) 1) - (push-in tn-next* tn live-list) - (frob-more-tns (push-in tn-next* mtn live-list))))))) + ((not num)) + ((not (zerop (sbit live-bits num))) + (when (tn-ref-write-p ref) + (setf (sbit live-bits num) 0) + (deletef-in tn-next* live-list tn) + (frob-more-tns (deletef-in tn-next* live-list mtn)))) + (t + (aver (not (tn-ref-write-p ref))) + (note-conflicts live-bits live-list tn num) + (frob-more-tns (note-conflicts live-bits live-list mtn num)) + (setf (sbit live-bits num) 1) + (push-in tn-next* tn live-list) + (frob-more-tns (push-in tn-next* mtn live-list))))))) ;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the ;;; current VOP's results, and make any dead ones live. This is @@ -749,12 +749,12 @@ '(do ((res (vop-results vop) (tn-ref-across res))) ((null res)) (let* ((tn (tn-ref-tn res)) - (num (tn-local-number tn))) + (num (tn-local-number tn))) (when (and num (zerop (sbit live-bits num))) - (unless (eq (svref ltns num) :more) - (note-conflicts live-bits live-list tn num) - (setf (sbit live-bits num) 1) - (push-in tn-next* tn live-list)))))) + (unless (eq (svref ltns num) :more) + (note-conflicts live-bits live-list tn num) + (setf (sbit live-bits num) 1) + (push-in tn-next* tn live-list)))))) ;;; Compute the block-local conflict information for BLOCK. We iterate ;;; over all the TN-REFs in a block in reference order, maintaining @@ -766,12 +766,12 @@ (compute-initial-conflicts block) (let ((ltns (ir2-block-local-tns block))) (do ((vop (ir2-block-last-vop block) - (vop-prev vop))) - ((null vop)) - (when (vop-info-save-p (vop-info vop)) - (conflictize-save-p-vop vop block live-bits)) - (ensure-results-live) - (scan-vop-refs))))) + (vop-prev vop))) + ((null vop)) + (when (vop-info-save-p (vop-info vop)) + (conflictize-save-p-vop vop block live-bits)) + (ensure-results-live) + (scan-vop-refs))))) ;;; Conflict analyze each block, and also add it. (defun lifetime-post-pass (component) @@ -785,11 +785,11 @@ (defun merge-alias-block-conflicts (conf oconf) (declare (type global-conflicts conf oconf)) (let* ((kind (global-conflicts-kind conf)) - (num (global-conflicts-number conf)) - (okind (global-conflicts-kind oconf)) - (onum (global-conflicts-number oconf)) - (block (global-conflicts-block oconf)) - (ltns (ir2-block-local-tns block))) + (num (global-conflicts-number conf)) + (okind (global-conflicts-kind oconf)) + (onum (global-conflicts-number oconf)) + (block (global-conflicts-block oconf)) + (ltns (ir2-block-local-tns block))) (cond ((eq okind :live)) ((eq kind :live) @@ -798,43 +798,43 @@ (setf (global-conflicts-number oconf) nil)) (t (unless (eq kind okind) - (setf (global-conflicts-kind oconf) :read)) + (setf (global-conflicts-kind oconf) :read)) ;; Make original conflict with all the local TNs the alias ;; conflicted with. (bit-ior (global-conflicts-conflicts oconf) - (global-conflicts-conflicts conf) - t) + (global-conflicts-conflicts conf) + t) (flet ((frob (x) - (unless (zerop (sbit x num)) - (setf (sbit x onum) 1)))) - ;; Make all the local TNs that conflicted with the alias - ;; conflict with the original. - (dotimes (i (ir2-block-local-tn-count block)) - (let ((tn (svref ltns i))) - (when (and tn (not (eq tn :more)) - (null (tn-global-conflicts tn))) - (frob (tn-local-conflicts tn))))) - ;; Same for global TNs... - (do ((current (ir2-block-global-tns block) - (global-conflicts-next-blockwise current))) - ((null current)) - (unless (eq (global-conflicts-kind current) :live) - (frob (global-conflicts-conflicts current)))) - ;; Make the original TN live everywhere that the alias was live. - (frob (ir2-block-written block)) - (frob (ir2-block-live-in block)) - (frob (ir2-block-live-out block)) - (do ((vop (ir2-block-start-vop block) - (vop-next vop))) - ((null vop)) - (let ((sset (vop-save-set vop))) - (when sset (frob sset))))))) + (unless (zerop (sbit x num)) + (setf (sbit x onum) 1)))) + ;; Make all the local TNs that conflicted with the alias + ;; conflict with the original. + (dotimes (i (ir2-block-local-tn-count block)) + (let ((tn (svref ltns i))) + (when (and tn (not (eq tn :more)) + (null (tn-global-conflicts tn))) + (frob (tn-local-conflicts tn))))) + ;; Same for global TNs... + (do ((current (ir2-block-global-tns block) + (global-conflicts-next-blockwise current))) + ((null current)) + (unless (eq (global-conflicts-kind current) :live) + (frob (global-conflicts-conflicts current)))) + ;; Make the original TN live everywhere that the alias was live. + (frob (ir2-block-written block)) + (frob (ir2-block-live-in block)) + (frob (ir2-block-live-out block)) + (do ((vop (ir2-block-start-vop block) + (vop-next vop))) + ((null vop)) + (let ((sset (vop-save-set vop))) + (when sset (frob sset))))))) ;; Delete the alias's conflict info. (when num (setf (svref ltns num) nil)) (deletef-in global-conflicts-next-blockwise - (ir2-block-global-tns block) - conf)) + (ir2-block-global-tns block) + conf)) (values)) @@ -843,10 +843,10 @@ (declare (type global-conflicts conf) (type tn new)) (setf (global-conflicts-tn conf) new) (let ((ltn-num (global-conflicts-number conf)) - (block (global-conflicts-block conf))) + (block (global-conflicts-block conf))) (deletef-in global-conflicts-next-blockwise - (ir2-block-global-tns block) - conf) + (ir2-block-global-tns block) + conf) (setf (global-conflicts-next-blockwise conf) nil) (insert-block-global-conflict conf block) (when ltn-num @@ -858,13 +858,13 @@ (defun ensure-global-tn (tn) (declare (type tn tn)) (cond ((tn-global-conflicts tn)) - ((tn-local tn) - (convert-to-global tn) - (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn)) - (tn-local-conflicts tn) - t)) - (t - (aver (and (null (tn-reads tn)) (null (tn-writes tn)))))) + ((tn-local tn) + (convert-to-global tn) + (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn)) + (tn-local-conflicts tn) + t)) + (t + (aver (and (null (tn-reads tn)) (null (tn-writes tn)))))) (values)) ;;; For each :ALIAS TN, destructively merge the conflict info into the @@ -883,54 +883,54 @@ (defun merge-alias-conflicts (component) (declare (type component component)) (do ((tn (ir2-component-alias-tns (component-info component)) - (tn-next tn))) + (tn-next tn))) ((null tn)) (let ((original (tn-save-tn tn))) (ensure-global-tn tn) (ensure-global-tn original) (let ((conf (tn-global-conflicts tn)) - (oconf (tn-global-conflicts original)) - (oprev nil)) - (loop - (unless oconf - (if oprev - (setf (global-conflicts-next-tnwise oprev) conf) - (setf (tn-global-conflicts original) conf)) - (do ((current conf (global-conflicts-next-tnwise current))) - ((null current)) - (change-global-conflicts-tn current original)) - (return)) - (let* ((block (global-conflicts-block conf)) - (num (ir2-block-number block)) - (onum (ir2-block-number (global-conflicts-block oconf)))) - - (cond ((< onum num) - (shiftf oprev oconf (global-conflicts-next-tnwise oconf))) - ((> onum num) - (if oprev - (setf (global-conflicts-next-tnwise oprev) conf) - (setf (tn-global-conflicts original) conf)) - (change-global-conflicts-tn conf original) - (shiftf oprev - conf - (global-conflicts-next-tnwise conf) - oconf)) - (t - (merge-alias-block-conflicts conf oconf) - (shiftf oprev oconf (global-conflicts-next-tnwise oconf)) - (setf conf (global-conflicts-next-tnwise conf))))) - (unless conf (return)))) + (oconf (tn-global-conflicts original)) + (oprev nil)) + (loop + (unless oconf + (if oprev + (setf (global-conflicts-next-tnwise oprev) conf) + (setf (tn-global-conflicts original) conf)) + (do ((current conf (global-conflicts-next-tnwise current))) + ((null current)) + (change-global-conflicts-tn current original)) + (return)) + (let* ((block (global-conflicts-block conf)) + (num (ir2-block-number block)) + (onum (ir2-block-number (global-conflicts-block oconf)))) + + (cond ((< onum num) + (shiftf oprev oconf (global-conflicts-next-tnwise oconf))) + ((> onum num) + (if oprev + (setf (global-conflicts-next-tnwise oprev) conf) + (setf (tn-global-conflicts original) conf)) + (change-global-conflicts-tn conf original) + (shiftf oprev + conf + (global-conflicts-next-tnwise conf) + oconf)) + (t + (merge-alias-block-conflicts conf oconf) + (shiftf oprev oconf (global-conflicts-next-tnwise oconf)) + (setf conf (global-conflicts-next-tnwise conf))))) + (unless conf (return)))) (flet ((frob (refs) - (let ((ref refs) - (next nil)) - (loop - (unless ref (return)) - (setq next (tn-ref-next ref)) - (change-tn-ref-tn ref original) - (setq ref next))))) - (frob (tn-reads tn)) - (frob (tn-writes tn))) + (let ((ref refs) + (next nil)) + (loop + (unless ref (return)) + (setq next (tn-ref-next ref)) + (change-tn-ref-tn ref original) + (setq ref next))))) + (frob (tn-reads tn)) + (frob (tn-writes tn))) (setf (tn-global-conflicts tn) nil))) (values)) @@ -953,61 +953,61 @@ (defun tns-conflict-local-global (x y) (let ((block (tn-local x))) (do ((conf (ir2-block-global-tns block) - (global-conflicts-next-blockwise conf))) - ((null conf) nil) + (global-conflicts-next-blockwise conf))) + ((null conf) nil) (when (eq (global-conflicts-tn conf) y) - (let ((num (global-conflicts-number conf))) - (return (or (not num) - (not (zerop (sbit (tn-local-conflicts x) - num)))))))))) + (let ((num (global-conflicts-number conf))) + (return (or (not num) + (not (zerop (sbit (tn-local-conflicts x) + num)))))))))) ;;; Test for conflict between two global TNs X and Y. (defun tns-conflict-global-global (x y) (declare (type tn x y)) (let* ((x-conf (tn-global-conflicts x)) - (x-num (ir2-block-number (global-conflicts-block x-conf))) - (y-conf (tn-global-conflicts y)) - (y-num (ir2-block-number (global-conflicts-block y-conf)))) + (x-num (ir2-block-number (global-conflicts-block x-conf))) + (y-conf (tn-global-conflicts y)) + (y-num (ir2-block-number (global-conflicts-block y-conf)))) (macrolet ((advance (n c) - `(progn - (setq ,c (global-conflicts-next-tnwise ,c)) - (unless ,c (return-from tns-conflict-global-global nil)) - (setq ,n (ir2-block-number (global-conflicts-block ,c))))) - (scan (g l lc) - `(do () - ((>= ,g ,l)) - (advance ,l ,lc)))) + `(progn + (setq ,c (global-conflicts-next-tnwise ,c)) + (unless ,c (return-from tns-conflict-global-global nil)) + (setq ,n (ir2-block-number (global-conflicts-block ,c))))) + (scan (g l lc) + `(do () + ((>= ,g ,l)) + (advance ,l ,lc)))) (loop - ;; x-conf, y-conf true, x-num, y-num corresponding block numbers. - (scan x-num y-num y-conf) - (scan y-num x-num x-conf) - (when (= x-num y-num) - (let ((ltn-num-x (global-conflicts-number x-conf))) - (unless (and ltn-num-x - (global-conflicts-number y-conf) - (zerop (sbit (global-conflicts-conflicts y-conf) - ltn-num-x))) - (return t)) - (advance x-num x-conf) - (advance y-num y-conf))))))) + ;; x-conf, y-conf true, x-num, y-num corresponding block numbers. + (scan x-num y-num y-conf) + (scan y-num x-num x-conf) + (when (= x-num y-num) + (let ((ltn-num-x (global-conflicts-number x-conf))) + (unless (and ltn-num-x + (global-conflicts-number y-conf) + (zerop (sbit (global-conflicts-conflicts y-conf) + ltn-num-x))) + (return t)) + (advance x-num x-conf) + (advance y-num y-conf))))))) ;;; Return true if X and Y are distinct and the lifetimes of X and Y ;;; overlap at any point. (defun tns-conflict (x y) (declare (type tn x y)) (let ((x-kind (tn-kind x)) - (y-kind (tn-kind y))) + (y-kind (tn-kind y))) (cond ((eq x y) nil) - ((or (eq x-kind :component) (eq y-kind :component)) t) - ((tn-global-conflicts x) - (if (tn-global-conflicts y) - (tns-conflict-global-global x y) - (tns-conflict-local-global y x))) - ((tn-global-conflicts y) - (tns-conflict-local-global x y)) - (t - (and (eq (tn-local x) (tn-local y)) - (not (zerop (sbit (tn-local-conflicts x) - (tn-local-number y))))))))) + ((or (eq x-kind :component) (eq y-kind :component)) t) + ((tn-global-conflicts x) + (if (tn-global-conflicts y) + (tns-conflict-global-global x y) + (tns-conflict-local-global y x))) + ((tn-global-conflicts y) + (tns-conflict-local-global x y)) + (t + (and (eq (tn-local x) (tn-local y)) + (not (zerop (sbit (tn-local-conflicts x) + (tn-local-number y))))))))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index f8211b7..1fef35a 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -101,15 +101,15 @@ (let ((return (node-dest call))) (when (return-p return) (let ((call-set (lambda-tail-set (node-home-lambda call))) - (fun-set (lambda-tail-set new-fun))) - (unless (eq call-set fun-set) - (let ((funs (tail-set-funs fun-set))) - (dolist (fun funs) - (setf (lambda-tail-set fun) call-set)) - (setf (tail-set-funs call-set) - (nconc (tail-set-funs call-set) funs))) - (reoptimize-lvar (return-result return)) - t))))) + (fun-set (lambda-tail-set new-fun))) + (unless (eq call-set fun-set) + (let ((funs (tail-set-funs fun-set))) + (dolist (fun funs) + (setf (lambda-tail-set fun) call-set)) + (setf (tail-set-funs call-set) + (nconc (tail-set-funs call-set) funs))) + (reoptimize-lvar (return-result return)) + t))))) ;;; Convert a combination into a local call. We PROPAGATE-TO-ARGS, set ;;; the combination kind to :LOCAL, add FUN to the CALLS of the @@ -170,47 +170,47 @@ (etypecase fun (clambda (let ((nargs (length (lambda-vars fun))) - (n-supplied (gensym)) - (temps (make-gensym-list (length (lambda-vars fun))))) + (n-supplied (gensym)) + (temps (make-gensym-list (length (lambda-vars fun))))) `(lambda (,n-supplied ,@temps) - (declare (type index ,n-supplied)) - ,(if (policy *lexenv* (zerop verify-arg-count)) - `(declare (ignore ,n-supplied)) - `(%verify-arg-count ,n-supplied ,nargs)) - (locally - (declare (optimize (merge-tail-calls 3))) - (%funcall ,fun ,@temps))))) + (declare (type index ,n-supplied)) + ,(if (policy *lexenv* (zerop verify-arg-count)) + `(declare (ignore ,n-supplied)) + `(%verify-arg-count ,n-supplied ,nargs)) + (locally + (declare (optimize (merge-tail-calls 3))) + (%funcall ,fun ,@temps))))) (optional-dispatch (let* ((min (optional-dispatch-min-args fun)) - (max (optional-dispatch-max-args fun)) - (more (optional-dispatch-more-entry fun)) - (n-supplied (gensym)) - (temps (make-gensym-list max))) + (max (optional-dispatch-max-args fun)) + (more (optional-dispatch-more-entry fun)) + (n-supplied (gensym)) + (temps (make-gensym-list max))) (collect ((entries)) ;; Force convertion of all entries (optional-dispatch-entry-point-fun fun 0) - (loop for ep in (optional-dispatch-entry-points fun) + (loop for ep in (optional-dispatch-entry-points fun) and n from min do (entries `((= ,n-supplied ,n) (%funcall ,(force ep) ,@(subseq temps 0 n))))) - `(lambda (,n-supplied ,@temps) - ;; FIXME: Make sure that INDEX type distinguishes between - ;; target and host. (Probably just make the SB!XC:DEFTYPE - ;; different from CL:DEFTYPE.) - (declare (type index ,n-supplied)) - (cond - ,@(if more (butlast (entries)) (entries)) - ,@(when more - `((,(if (zerop min) t `(>= ,n-supplied ,max)) - ,(let ((n-context (gensym)) - (n-count (gensym))) - `(multiple-value-bind (,n-context ,n-count) - (%more-arg-context ,n-supplied ,max) - (locally - (declare (optimize (merge-tail-calls 3))) - (%funcall ,more ,@temps ,n-context ,n-count))))))) - (t - (%arg-count-error ,n-supplied))))))))) + `(lambda (,n-supplied ,@temps) + ;; FIXME: Make sure that INDEX type distinguishes between + ;; target and host. (Probably just make the SB!XC:DEFTYPE + ;; different from CL:DEFTYPE.) + (declare (type index ,n-supplied)) + (cond + ,@(if more (butlast (entries)) (entries)) + ,@(when more + `((,(if (zerop min) t `(>= ,n-supplied ,max)) + ,(let ((n-context (gensym)) + (n-count (gensym))) + `(multiple-value-bind (,n-context ,n-count) + (%more-arg-context ,n-supplied ,max) + (locally + (declare (optimize (merge-tail-calls 3))) + (%funcall ,more ,@temps ,n-context ,n-count))))))) + (t + (%arg-count-error ,n-supplied))))))))) ;;; Make an external entry point (XEP) for FUN and return it. We ;;; convert the result of MAKE-XEP-LAMBDA in the correct environment, @@ -226,22 +226,22 @@ (aver (null (functional-entry-fun fun))) (with-ir1-environment-from-node (lambda-bind (main-entry fun)) (let ((res (ir1-convert-lambda (make-xep-lambda-expression fun) - :debug-name (debug-name + :debug-name (debug-name 'xep (leaf-debug-name fun))))) (setf (functional-kind res) :external - (leaf-ever-used res) t - (functional-entry-fun res) fun - (functional-entry-fun fun) res - (component-reanalyze *current-component*) t) + (leaf-ever-used res) t + (functional-entry-fun res) fun + (functional-entry-fun fun) res + (component-reanalyze *current-component*) t) (reoptimize-component *current-component* :maybe) (etypecase fun - (clambda - (locall-analyze-fun-1 fun)) - (optional-dispatch - (dolist (ep (optional-dispatch-entry-points fun)) - (locall-analyze-fun-1 (force ep))) - (when (optional-dispatch-more-entry fun) - (locall-analyze-fun-1 (optional-dispatch-more-entry fun))))) + (clambda + (locall-analyze-fun-1 fun)) + (optional-dispatch + (dolist (ep (optional-dispatch-entry-points fun)) + (locall-analyze-fun-1 (force ep))) + (when (optional-dispatch-more-entry fun) + (locall-analyze-fun-1 (optional-dispatch-more-entry fun))))) res))) ;;; Notice a REF that is not in a local-call context. If the REF is @@ -254,9 +254,9 @@ (declare (type ref ref)) (let ((fun (ref-leaf ref))) (unless (or (xep-p fun) - (member (functional-kind fun) '(:escape :cleanup))) + (member (functional-kind fun) '(:escape :cleanup))) (change-ref-leaf ref (or (functional-entry-fun fun) - (make-xep fun)))))) + (make-xep fun)))))) ;;; Attempt to convert all references to FUN to local calls. The ;;; reference must be the function for a call, and the function lvar @@ -277,7 +277,7 @@ (let ((refs (leaf-refs fun))) (dolist (ref refs) (let* ((lvar (node-lvar ref)) - (dest (when lvar (lvar-dest lvar)))) + (dest (when lvar (lvar-dest lvar)))) (unless (node-to-be-deleted-p ref) (cond ((and (basic-combination-p dest) (eq (basic-combination-fun dest) lvar) @@ -315,36 +315,36 @@ (aver-live-component component) (loop (let* ((new-functional (pop (component-new-functionals component))) - (functional (or new-functional - (pop (component-reanalyze-functionals component))))) + (functional (or new-functional + (pop (component-reanalyze-functionals component))))) (unless functional - (return)) + (return)) (let ((kind (functional-kind functional))) - (cond ((or (functional-somewhat-letlike-p functional) - (memq kind '(:deleted :zombie))) - (values)) ; nothing to do - ((and (null (leaf-refs functional)) (eq kind nil) - (not (functional-entry-fun functional))) - (delete-functional functional)) - (t - ;; Fix/check FUNCTIONAL's relationship to COMPONENT-LAMDBAS. - (cond ((not (lambda-p functional)) - ;; Since FUNCTIONAL isn't a LAMBDA, this doesn't - ;; apply: no-op. - (values)) - (new-functional ; FUNCTIONAL came from - ; NEW-FUNCTIONALS, hence is new. - ;; FUNCTIONAL becomes part of COMPONENT-LAMBDAS now. - (aver (not (member functional - (component-lambdas component)))) - (push functional (component-lambdas component))) - (t ; FUNCTIONAL is old. - ;; FUNCTIONAL should be in COMPONENT-LAMBDAS already. - (aver (member functional (component-lambdas - component))))) - (locall-analyze-fun-1 functional) - (when (lambda-p functional) - (maybe-let-convert functional))))))) + (cond ((or (functional-somewhat-letlike-p functional) + (memq kind '(:deleted :zombie))) + (values)) ; nothing to do + ((and (null (leaf-refs functional)) (eq kind nil) + (not (functional-entry-fun functional))) + (delete-functional functional)) + (t + ;; Fix/check FUNCTIONAL's relationship to COMPONENT-LAMDBAS. + (cond ((not (lambda-p functional)) + ;; Since FUNCTIONAL isn't a LAMBDA, this doesn't + ;; apply: no-op. + (values)) + (new-functional ; FUNCTIONAL came from + ; NEW-FUNCTIONALS, hence is new. + ;; FUNCTIONAL becomes part of COMPONENT-LAMBDAS now. + (aver (not (member functional + (component-lambdas component)))) + (push functional (component-lambdas component))) + (t ; FUNCTIONAL is old. + ;; FUNCTIONAL should be in COMPONENT-LAMBDAS already. + (aver (member functional (component-lambdas + component))))) + (locall-analyze-fun-1 functional) + (when (lambda-p functional) + (maybe-let-convert functional))))))) (values)) (defun locall-analyze-clambdas-until-done (clambdas) @@ -352,15 +352,15 @@ (let ((did-something nil)) (dolist (clambda clambdas) (let* ((component (lambda-component clambda)) - (*all-components* (list component))) - ;; The original CMU CL code seemed to implicitly assume that - ;; COMPONENT is the only one here. Let's make that explicit. - (aver (= 1 (length (functional-components clambda)))) - (aver (eql component (first (functional-components clambda)))) - (when (or (component-new-functionals component) + (*all-components* (list component))) + ;; The original CMU CL code seemed to implicitly assume that + ;; COMPONENT is the only one here. Let's make that explicit. + (aver (= 1 (length (functional-components clambda)))) + (aver (eql component (first (functional-components clambda)))) + (when (or (component-new-functionals component) (component-reanalyze-functionals component)) - (setf did-something t) - (locall-analyze-component component)))) + (setf did-something t) + (locall-analyze-component component)))) (unless did-something (return)))) (values)) @@ -371,10 +371,10 @@ ;;; reference. (defun maybe-expand-local-inline (original-functional ref call) (if (and (policy call - (and (>= speed space) - (>= speed compilation-speed))) - (not (eq (functional-kind (node-home-lambda call)) :external)) - (inline-expansion-ok call)) + (and (>= speed space) + (>= speed compilation-speed))) + (not (eq (functional-kind (node-home-lambda call)) :external)) + (inline-expansion-ok call)) (let* ((end (component-last-block (node-component call))) (pred (block-prev end))) (multiple-value-bind (losing-local-object converted-lambda) @@ -384,8 +384,8 @@ (values nil (ir1-convert-lambda (functional-inline-expansion original-functional) - :debug-name (debug-name 'local-inline - (leaf-debug-name + :debug-name (debug-name 'local-inline + (leaf-debug-name original-functional))))))) (cond (losing-local-object (if (functional-p losing-local-object) @@ -433,35 +433,35 @@ (defun convert-call-if-possible (ref call) (declare (type ref ref) (type basic-combination call)) (let* ((block (node-block call)) - (component (block-component block)) - (original-fun (ref-leaf ref))) + (component (block-component block)) + (original-fun (ref-leaf ref))) (aver (functional-p original-fun)) (unless (or (member (basic-combination-kind call) '(:local :error)) (node-to-be-deleted-p call) - (member (functional-kind original-fun) - '(:toplevel-xep :deleted)) - (not (or (eq (component-kind component) :initial) - (eq (block-component - (node-block - (lambda-bind (main-entry original-fun)))) - component)))) + (member (functional-kind original-fun) + '(:toplevel-xep :deleted)) + (not (or (eq (component-kind component) :initial) + (eq (block-component + (node-block + (lambda-bind (main-entry original-fun)))) + component)))) (let ((fun (if (xep-p original-fun) - (functional-entry-fun original-fun) - original-fun)) - (*compiler-error-context* call)) + (functional-entry-fun original-fun) + original-fun)) + (*compiler-error-context* call)) - (when (and (eq (functional-inlinep fun) :inline) - (rest (leaf-refs original-fun))) - (setq fun (maybe-expand-local-inline fun ref call))) + (when (and (eq (functional-inlinep fun) :inline) + (rest (leaf-refs original-fun))) + (setq fun (maybe-expand-local-inline fun ref call))) - (aver (member (functional-kind fun) - '(nil :escape :cleanup :optional))) - (cond ((mv-combination-p call) - (convert-mv-call ref call fun)) - ((lambda-p fun) - (convert-lambda-call ref call fun)) - (t - (convert-hairy-call ref call fun)))))) + (aver (member (functional-kind fun) + '(nil :escape :cleanup :optional))) + (cond ((mv-combination-p call) + (convert-mv-call ref call fun)) + ((lambda-p fun) + (convert-lambda-call ref call fun)) + (t + (convert-hairy-call ref call fun)))))) (values)) @@ -483,8 +483,8 @@ (defun convert-mv-call (ref call fun) (declare (type ref ref) (type mv-combination call) (type functional fun)) (when (and (looks-like-an-mv-bind fun) - (singleton-p (leaf-refs fun)) - (singleton-p (basic-combination-args call))) + (singleton-p (leaf-refs fun)) + (singleton-p (basic-combination-args call))) (let* ((*current-component* (node-component ref)) (ep (optional-dispatch-entry-point-fun fun (optional-dispatch-max-args fun)))) @@ -509,16 +509,16 @@ (defun convert-lambda-call (ref call fun) (declare (type ref ref) (type combination call) (type clambda fun)) (let ((nargs (length (lambda-vars fun))) - (n-call-args (length (combination-args call)))) + (n-call-args (length (combination-args call)))) (cond ((= n-call-args nargs) - (convert-call ref call fun)) - (t - (warn - 'local-argument-mismatch - :format-control - "function called with ~R argument~:P, but wants exactly ~R" - :format-arguments (list n-call-args nargs)) - (setf (basic-combination-kind call) :error))))) + (convert-call ref call fun)) + (t + (warn + 'local-argument-mismatch + :format-control + "function called with ~R argument~:P, but wants exactly ~R" + :format-arguments (list n-call-args nargs)) + (setf (basic-combination-kind call) :error))))) ;;;; &OPTIONAL, &MORE and &KEYWORD calls @@ -529,32 +529,32 @@ ;;; that have a &MORE (or &REST) arg. (defun convert-hairy-call (ref call fun) (declare (type ref ref) (type combination call) - (type optional-dispatch fun)) + (type optional-dispatch fun)) (let ((min-args (optional-dispatch-min-args fun)) - (max-args (optional-dispatch-max-args fun)) - (call-args (length (combination-args call)))) + (max-args (optional-dispatch-max-args fun)) + (call-args (length (combination-args call)))) (cond ((< call-args min-args) - (warn - 'local-argument-mismatch - :format-control - "function called with ~R argument~:P, but wants at least ~R" - :format-arguments (list call-args min-args)) - (setf (basic-combination-kind call) :error)) - ((<= call-args max-args) - (convert-call ref call + (warn + 'local-argument-mismatch + :format-control + "function called with ~R argument~:P, but wants at least ~R" + :format-arguments (list call-args min-args)) + (setf (basic-combination-kind call) :error)) + ((<= call-args max-args) + (convert-call ref call (let ((*current-component* (node-component ref))) (optional-dispatch-entry-point-fun fun (- call-args min-args))))) - ((optional-dispatch-more-entry fun) - (convert-more-call ref call fun)) - (t - (warn - 'local-argument-mismatch - :format-control - "function called with ~R argument~:P, but wants at most ~R" - :format-arguments - (list call-args max-args)) - (setf (basic-combination-kind call) :error)))) + ((optional-dispatch-more-entry fun) + (convert-more-call ref call fun)) + (t + (warn + 'local-argument-mismatch + :format-control + "function called with ~R argument~:P, but wants at most ~R" + :format-arguments + (list call-args max-args)) + (setf (basic-combination-kind call) :error)))) (values)) ;;; This function is used to convert a call to an entry point when @@ -570,14 +570,14 @@ ;;; that everything gets converted during the single pass. (defun convert-hairy-fun-entry (ref call entry vars ignores args) (declare (list vars ignores args) (type ref ref) (type combination call) - (type clambda entry)) + (type clambda entry)) (let ((new-fun - (with-ir1-environment-from-node call - (ir1-convert-lambda - `(lambda ,vars - (declare (ignorable ,@ignores)) - (%funcall ,entry ,@args)) - :debug-name (debug-name 'hairy-function-entry + (with-ir1-environment-from-node call + (ir1-convert-lambda + `(lambda ,vars + (declare (ignorable ,@ignores)) + (%funcall ,entry ,@args)) + :debug-name (debug-name 'hairy-function-entry (lvar-fun-name (basic-combination-fun call))))))) (convert-call ref call new-fun) @@ -602,52 +602,52 @@ (defun convert-more-call (ref call fun) (declare (type ref ref) (type combination call) (type optional-dispatch fun)) (let* ((max (optional-dispatch-max-args fun)) - (arglist (optional-dispatch-arglist fun)) - (args (combination-args call)) - (more (nthcdr max args)) - (flame (policy call (or (> speed inhibit-warnings) - (> space inhibit-warnings)))) - (loser nil) + (arglist (optional-dispatch-arglist fun)) + (args (combination-args call)) + (more (nthcdr max args)) + (flame (policy call (or (> speed inhibit-warnings) + (> space inhibit-warnings)))) + (loser nil) (allowp nil) (allow-found nil) - (temps (make-gensym-list max)) - (more-temps (make-gensym-list (length more)))) + (temps (make-gensym-list max)) + (more-temps (make-gensym-list (length more)))) (collect ((ignores) - (supplied) - (key-vars)) + (supplied) + (key-vars)) (dolist (var arglist) - (let ((info (lambda-var-arg-info var))) - (when info - (ecase (arg-info-kind info) - (:keyword - (key-vars var)) - ((:rest :optional)) - ((:more-context :more-count) - (compiler-warn "can't local-call functions with &MORE args") - (setf (basic-combination-kind call) :error) - (return-from convert-more-call)))))) + (let ((info (lambda-var-arg-info var))) + (when info + (ecase (arg-info-kind info) + (:keyword + (key-vars var)) + ((:rest :optional)) + ((:more-context :more-count) + (compiler-warn "can't local-call functions with &MORE args") + (setf (basic-combination-kind call) :error) + (return-from convert-more-call)))))) (when (optional-dispatch-keyp fun) - (when (oddp (length more)) - (compiler-warn "function called with odd number of ~ + (when (oddp (length more)) + (compiler-warn "function called with odd number of ~ arguments in keyword portion") - (setf (basic-combination-kind call) :error) - (return-from convert-more-call)) + (setf (basic-combination-kind call) :error) + (return-from convert-more-call)) - (do ((key more (cddr key)) - (temp more-temps (cddr temp))) - ((null key)) - (let ((lvar (first key))) - (unless (constant-lvar-p lvar) - (when flame - (compiler-notify "non-constant keyword in keyword call")) - (setf (basic-combination-kind call) :error) - (return-from convert-more-call)) + (do ((key more (cddr key)) + (temp more-temps (cddr temp))) + ((null key)) + (let ((lvar (first key))) + (unless (constant-lvar-p lvar) + (when flame + (compiler-notify "non-constant keyword in keyword call")) + (setf (basic-combination-kind call) :error) + (return-from convert-more-call)) - (let ((name (lvar-value lvar)) - (dummy (first temp)) - (val (second temp))) + (let ((name (lvar-value lvar)) + (dummy (first temp)) + (val (second temp))) (when (and (eq name :allow-other-keys) (not allow-found)) (let ((val (second key))) (cond ((constant-lvar-p val) @@ -657,55 +657,55 @@ (compiler-notify "non-constant :ALLOW-OTHER-KEYS value")) (setf (basic-combination-kind call) :error) (return-from convert-more-call))))) - (dolist (var (key-vars) - (progn - (ignores dummy val) + (dolist (var (key-vars) + (progn + (ignores dummy val) (unless (eq name :allow-other-keys) (setq loser (list name))))) - (let ((info (lambda-var-arg-info var))) - (when (eq (arg-info-key info) name) - (ignores dummy) - (if (member var (supplied) :key #'car) - (ignores val) - (supplied (cons var val))) - (return))))))) + (let ((info (lambda-var-arg-info var))) + (when (eq (arg-info-key info) name) + (ignores dummy) + (if (member var (supplied) :key #'car) + (ignores val) + (supplied (cons var val))) + (return))))))) - (when (and loser (not (optional-dispatch-allowp fun)) (not allowp)) - (compiler-warn "function called with unknown argument keyword ~S" - (car loser)) - (setf (basic-combination-kind call) :error) - (return-from convert-more-call))) + (when (and loser (not (optional-dispatch-allowp fun)) (not allowp)) + (compiler-warn "function called with unknown argument keyword ~S" + (car loser)) + (setf (basic-combination-kind call) :error) + (return-from convert-more-call))) (collect ((call-args)) - (do ((var arglist (cdr var)) - (temp temps (cdr temp))) - ((null var)) - (let ((info (lambda-var-arg-info (car var)))) - (if info - (ecase (arg-info-kind info) - (:optional - (call-args (car temp)) - (when (arg-info-supplied-p info) - (call-args t))) - (:rest - (call-args `(list ,@more-temps)) - (return)) - (:keyword - (return))) - (call-args (car temp))))) + (do ((var arglist (cdr var)) + (temp temps (cdr temp))) + ((null var)) + (let ((info (lambda-var-arg-info (car var)))) + (if info + (ecase (arg-info-kind info) + (:optional + (call-args (car temp)) + (when (arg-info-supplied-p info) + (call-args t))) + (:rest + (call-args `(list ,@more-temps)) + (return)) + (:keyword + (return))) + (call-args (car temp))))) - (dolist (var (key-vars)) - (let ((info (lambda-var-arg-info var)) - (temp (cdr (assoc var (supplied))))) - (if temp - (call-args temp) - (call-args (arg-info-default info))) - (when (arg-info-supplied-p info) - (call-args (not (null temp)))))) + (dolist (var (key-vars)) + (let ((info (lambda-var-arg-info var)) + (temp (cdr (assoc var (supplied))))) + (if temp + (call-args temp) + (call-args (arg-info-default info))) + (when (arg-info-supplied-p info) + (call-args (not (null temp)))))) - (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun) - (append temps more-temps) - (ignores) (call-args))))) + (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun) + (append temps more-temps) + (ignores) (call-args))))) (values)) @@ -741,13 +741,13 @@ (defun insert-let-body (clambda call) (declare (type clambda clambda) (type basic-combination call)) (let* ((call-block (node-block call)) - (bind-block (node-block (lambda-bind clambda))) - (component (block-component call-block))) + (bind-block (node-block (lambda-bind clambda))) + (component (block-component call-block))) (aver-live-component component) (let ((clambda-component (block-component bind-block))) (unless (eq clambda-component component) - (aver (eq (component-kind component) :initial)) - (join-components component clambda-component))) + (aver (eq (component-kind component) :initial)) + (join-components component clambda-component))) (let ((*current-component* component)) (node-ends-block call)) (destructuring-bind (next-block) @@ -780,7 +780,7 @@ ;; FINALIZE-XEP-DEFINITION tried to find out its DEFINED-TYPE from ;; the now-NILed-out TAIL-SET. So.. ;; - ;; To deal with this problem, we no longer NIL out + ;; To deal with this problem, we no longer NIL out ;; (LAMBDA-TAIL-SET CLAMBDA) here. Instead: ;; * If we're the only function in TAIL-SET-FUNS, it should ;; be safe to leave ourself linked to it, and it to you. @@ -793,13 +793,13 @@ ;; FINALIZE-XEP-DEFINITION) which might want to ;; know about our return type. (let* ((old-tail-set (lambda-tail-set clambda)) - (old-tail-set-funs (tail-set-funs old-tail-set))) + (old-tail-set-funs (tail-set-funs old-tail-set))) (unless (= 1 (length old-tail-set-funs)) (setf (tail-set-funs old-tail-set) - (delete clambda old-tail-set-funs)) + (delete clambda old-tail-set-funs)) (let ((new-tail-set (copy-tail-set old-tail-set))) - (setf (lambda-tail-set clambda) new-tail-set - (tail-set-funs new-tail-set) (list clambda))))) + (setf (lambda-tail-set clambda) new-tail-set + (tail-set-funs new-tail-set) (list clambda))))) ;; The documentation on TAIL-SET-INFO doesn't tell whether it could ;; remain valid in this case, so we nuke it on the theory that ;; missing information tends to be less dangerous than incorrect @@ -821,14 +821,14 @@ (let ((component (node-component call))) (unlink-blocks (component-head component) (lambda-block clambda)) (setf (component-lambdas component) - (delete clambda (component-lambdas component))) + (delete clambda (component-lambdas component))) (setf (component-reanalyze component) t)) (setf (lambda-call-lexenv clambda) (node-lexenv call)) (depart-from-tail-set clambda) (let* ((home (node-home-lambda call)) - (home-physenv (lambda-physenv home))) + (home-physenv (lambda-physenv home))) (aver (not (eq home clambda))) @@ -841,7 +841,7 @@ (let ((lets (lambda-lets clambda))) (dolist (let lets) (setf (lambda-home let) home) - (setf (lambda-physenv let) home-physenv)) + (setf (lambda-physenv let) home-physenv)) (setf (lambda-lets home) (nconc lets (lambda-lets home)))) ;; CLAMBDA no longer has an independent existence as an entity ;; which has LETs. @@ -872,13 +872,13 @@ ;;; instead. Move all the uses of the result lvar to CALL's lvar. (defun move-return-uses (fun call next-block) (declare (type clambda fun) (type basic-combination call) - (type cblock next-block)) + (type cblock next-block)) (let* ((return (lambda-return fun)) - (return-block (progn + (return-block (progn (ensure-block-start (node-prev return)) (node-block return)))) (unlink-blocks return-block - (component-tail (block-component return-block))) + (component-tail (block-component return-block))) (link-blocks return-block next-block) (unlink-node return) (delete-return return) @@ -905,26 +905,26 @@ (dolist (called (lambda-calls-or-closes fun)) (when (lambda-p called) (dolist (ref (leaf-refs called)) - (let ((this-call (node-dest ref))) - (when (and this-call - (node-tail-p this-call) - (eq (node-home-lambda this-call) fun)) - (setf (node-tail-p this-call) nil) - (ecase (functional-kind called) - ((nil :cleanup :optional) - (let ((block (node-block this-call)) - (lvar (node-lvar call))) - (unlink-blocks block (first (block-succ block))) - (link-blocks block next-block) + (let ((this-call (node-dest ref))) + (when (and this-call + (node-tail-p this-call) + (eq (node-home-lambda this-call) fun)) + (setf (node-tail-p this-call) nil) + (ecase (functional-kind called) + ((nil :cleanup :optional) + (let ((block (node-block this-call)) + (lvar (node-lvar call))) + (unlink-blocks block (first (block-succ block))) + (link-blocks block next-block) (aver (not (node-lvar this-call))) - (add-lvar-use this-call lvar))) - (:deleted) - ;; The called function might be an assignment in the - ;; case where we are currently converting that function. - ;; In steady-state, assignments never appear as a called - ;; function. - (:assignment - (aver (eq called fun))))))))) + (add-lvar-use this-call lvar))) + (:deleted) + ;; The called function might be an assignment in the + ;; case where we are currently converting that function. + ;; In steady-state, assignments never appear as a called + ;; function. + (:assignment + (aver (eq called fun))))))))) (values)) ;;; Deal with returning from a LET or assignment that we are @@ -952,28 +952,28 @@ ;;; move the return to the caller. (defun move-return-stuff (fun call next-block) (declare (type clambda fun) (type basic-combination call) - (type (or cblock null) next-block)) + (type (or cblock null) next-block)) (when next-block (unconvert-tail-calls fun call next-block)) (let* ((return (lambda-return fun)) - (call-fun (node-home-lambda call)) - (call-return (lambda-return call-fun))) + (call-fun (node-home-lambda call)) + (call-return (lambda-return call-fun))) (when (and call-return (block-delete-p (node-block call-return))) (delete-return call-return) (unlink-node call-return) (setq call-return nil)) (cond ((not return)) - ((or next-block call-return) - (unless (block-delete-p (node-block return)) + ((or next-block call-return) + (unless (block-delete-p (node-block return)) (unless next-block (ensure-block-start (node-prev call-return)) (setq next-block (node-block call-return))) - (move-return-uses fun call next-block))) - (t - (aver (node-tail-p call)) - (setf (lambda-return call-fun) return) - (setf (return-lambda return) call-fun) + (move-return-uses fun call next-block))) + (t + (aver (node-tail-p call)) + (setf (lambda-return call-fun) return) + (setf (return-lambda return) call-fun) (setf (lambda-return fun) nil)))) (%delete-lvar-use call) ; LET call does not have value semantics (values)) @@ -1017,12 +1017,12 @@ (when (leaf-has-source-name-p clambda) ;; ANSI requires that explicit NOTINLINE be respected. (or (eq (lambda-inlinep clambda) :notinline) - ;; If (= LET-CONVERTION 0) we can guess that inlining - ;; generally won't be appreciated, but if the user - ;; specifically requests inlining, that takes precedence over - ;; our general guess. - (and (policy clambda (= let-convertion 0)) - (not (eq (lambda-inlinep clambda) :inline)))))) + ;; If (= LET-CONVERTION 0) we can guess that inlining + ;; generally won't be appreciated, but if the user + ;; specifically requests inlining, that takes precedence over + ;; our general guess. + (and (policy clambda (= let-convertion 0)) + (not (eq (lambda-inlinep clambda) :inline)))))) ;;; We also don't convert calls to named functions which appear in the ;;; initial component, delaying this until optimization. This @@ -1030,9 +1030,9 @@ ;;; may have references added due to later local inline expansion. (defun ok-initial-convert-p (fun) (not (and (leaf-has-source-name-p fun) - (or (declarations-suppress-let-conversion-p fun) - (eq (component-kind (lambda-component fun)) - :initial))))) + (or (declarations-suppress-let-conversion-p fun) + (eq (component-kind (lambda-component fun)) + :initial))))) ;;; This function is called when there is some reason to believe that ;;; CLAMBDA might be converted into a LET. This is done after local @@ -1060,30 +1060,30 @@ ;; OK-INITIAL-CONVERT-P. (let ((refs (leaf-refs clambda))) (when (and refs - (null (rest refs)) - (memq (functional-kind clambda) '(nil :assignment)) - (not (functional-entry-fun clambda))) - (binding* ((ref (first refs)) + (null (rest refs)) + (memq (functional-kind clambda) '(nil :assignment)) + (not (functional-entry-fun clambda))) + (binding* ((ref (first refs)) (ref-lvar (node-lvar ref) :exit-if-null) (dest (lvar-dest ref-lvar))) - (when (and (basic-combination-p dest) - (eq (basic-combination-fun dest) ref-lvar) - (eq (basic-combination-kind dest) :local) + (when (and (basic-combination-p dest) + (eq (basic-combination-fun dest) ref-lvar) + (eq (basic-combination-kind dest) :local) (not (node-to-be-deleted-p dest)) (not (block-delete-p (lambda-block clambda))) - (cond ((ok-initial-convert-p clambda) t) - (t - (reoptimize-lvar ref-lvar) - nil))) + (cond ((ok-initial-convert-p clambda) t) + (t + (reoptimize-lvar ref-lvar) + nil))) (when (eq clambda (node-home-lambda dest)) (delete-lambda clambda) (return-from maybe-let-convert nil)) - (unless (eq (functional-kind clambda) :assignment) + (unless (eq (functional-kind clambda) :assignment) (let-convert clambda dest)) - (reoptimize-call dest) - (setf (functional-kind clambda) - (if (mv-combination-p dest) :mv-let :let)))) - t)))) + (reoptimize-call dest) + (setf (functional-kind clambda) + (if (mv-combination-p dest) :mv-let :let)))) + t)))) ;;;; tail local calls and assignments @@ -1095,14 +1095,14 @@ (declare (type cblock block1 block2)) (or (eq block1 block2) (let ((cleanup2 (block-start-cleanup block2))) - (do ((cleanup (block-end-cleanup block1) - (node-enclosing-cleanup (cleanup-mess-up cleanup)))) - ((eq cleanup cleanup2) t) - (case (cleanup-kind cleanup) - ((:block :tagbody) - (unless (null (entry-exits (cleanup-mess-up cleanup))) - (return nil))) - (t (return nil))))))) + (do ((cleanup (block-end-cleanup block1) + (node-enclosing-cleanup (cleanup-mess-up cleanup)))) + ((eq cleanup cleanup2) t) + (case (cleanup-kind cleanup) + ((:block :tagbody) + (unless (null (entry-exits (cleanup-mess-up cleanup))) + (return nil))) + (t (return nil))))))) ;;; If a potentially TR local call really is TR, then convert it to ;;; jump directly to the called function. We also call @@ -1115,22 +1115,22 @@ (aver (return-p return)) (when (and (not (node-tail-p call)) ; otherwise already converted ;; this is a tail call - (immediately-used-p (return-result return) call) - (only-harmless-cleanups (node-block call) - (node-block return)) + (immediately-used-p (return-result return) call) + (only-harmless-cleanups (node-block call) + (node-block return)) ;; If the call is in an XEP, we might decide to make it ;; non-tail so that we can use known return inside the ;; component. - (not (eq (functional-kind (node-home-lambda call)) - :external)) + (not (eq (functional-kind (node-home-lambda call)) + :external)) (not (block-delete-p (lambda-block fun)))) (node-ends-block call) (let ((block (node-block call))) - (setf (node-tail-p call) t) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (lambda-block fun)) + (setf (node-tail-p call) t) + (unlink-blocks block (first (block-succ block))) + (link-blocks block (lambda-block fun)) (delete-lvar-use call) - (values t (maybe-convert-to-assignment fun)))))) + (values t (maybe-convert-to-assignment fun)))))) ;;; This is called when we believe it might make sense to convert ;;; CLAMBDA to an assignment. All this function really does is @@ -1138,7 +1138,7 @@ ;;; combined with the calling function's environment. We can convert ;;; when: ;;; -- The function is a normal, non-entry function, and -;;; -- Except for one call, all calls must be tail recursive calls +;;; -- Except for one call, all calls must be tail recursive calls ;;; in the called function (i.e. are self-recursive tail calls) ;;; -- OK-INITIAL-CONVERT-P is true. ;;; @@ -1156,24 +1156,24 @@ (defun maybe-convert-to-assignment (clambda) (declare (type clambda clambda)) (when (and (not (functional-kind clambda)) - (not (functional-entry-fun clambda))) + (not (functional-entry-fun clambda))) (let ((outside-non-tail-call nil) - (outside-call nil)) + (outside-call nil)) (when (and (dolist (ref (leaf-refs clambda) t) - (let ((dest (node-dest ref))) - (when (or (not dest) + (let ((dest (node-dest ref))) + (when (or (not dest) (block-delete-p (node-block dest))) (return nil)) - (let ((home (node-home-lambda ref))) - (unless (eq home clambda) - (when outside-call - (return nil)) - (setq outside-call dest)) - (unless (node-tail-p dest) - (when (or outside-non-tail-call (eq home clambda)) - (return nil)) - (setq outside-non-tail-call dest))))) - (ok-initial-convert-p clambda)) + (let ((home (node-home-lambda ref))) + (unless (eq home clambda) + (when outside-call + (return nil)) + (setq outside-call dest)) + (unless (node-tail-p dest) + (when (or outside-non-tail-call (eq home clambda)) + (return nil)) + (setq outside-non-tail-call dest))))) + (ok-initial-convert-p clambda)) (cond (outside-call (setf (functional-kind clambda) :assignment) (let-convert clambda outside-call) (when outside-non-tail-call diff --git a/src/compiler/loop.lisp b/src/compiler/loop.lisp index c43c056..4109eae 100644 --- a/src/compiler/loop.lisp +++ b/src/compiler/loop.lisp @@ -23,7 +23,7 @@ ;;; NIL when we are done. (defun find-dominators (component) (let ((head (loop-head (component-outer-loop component))) - changed) + changed) (let ((set (make-sset))) (sset-adjoin head set) (setf (block-dominators head) set)) @@ -31,16 +31,16 @@ (setq changed nil) (do-blocks (block component :tail) (let ((dom (block-dominators block))) - (when dom (sset-delete block dom)) - (dolist (pred (block-pred block)) - (let ((pdom (block-dominators pred))) - (when pdom - (if dom - (when (sset-intersection dom pdom) - (setq changed t)) - (setq dom (copy-sset pdom) changed t))))) - (setf (block-dominators block) dom) - (when dom (sset-adjoin block dom)))) + (when dom (sset-delete block dom)) + (dolist (pred (block-pred block)) + (let ((pdom (block-dominators pred))) + (when pdom + (if dom + (when (sset-intersection dom pdom) + (setq changed t)) + (setq dom (copy-sset pdom) changed t))))) + (setf (block-dominators block) dom) + (when dom (sset-adjoin block dom)))) (unless changed (return))))) @@ -50,8 +50,8 @@ (defun dominates-p (block1 block2) (let ((set (block-dominators block2))) (if set - (sset-member block1 set) - t))) + (sset-member block1 set) + t))) ;;; LOOP-ANALYZE -- Interface ;;; @@ -72,15 +72,15 @@ (setf (loop-blocks loop) nil) (do-blocks (block component) (let ((number (block-number block))) - (dolist (pred (block-pred block)) - (when (<= (block-number pred) number) - (when (note-loop-head block component) - (clear-flags component) - (setf (block-flag block) :good) - (dolist (succ (block-succ block)) - (find-strange-loop-blocks succ block)) - (find-strange-loop-segments block component)) - (return))))) + (dolist (pred (block-pred block)) + (when (<= (block-number pred) number) + (when (note-loop-head block component) + (clear-flags component) + (setf (block-flag block) :good) + (dolist (succ (block-succ block)) + (find-strange-loop-blocks succ block)) + (find-strange-loop-segments block component)) + (return))))) (find-loop-blocks (component-outer-loop component)))) @@ -106,22 +106,22 @@ (dolist (sub-loop (loop-inferiors loop)) (dolist (exit (loop-exits sub-loop)) (dolist (succ (block-succ exit)) - (find-blocks-from-here succ loop)))) - + (find-blocks-from-here succ loop)))) + (collect ((exits)) (dolist (sub-loop (loop-inferiors loop)) (dolist (exit (loop-exits sub-loop)) - (dolist (succ (block-succ exit)) - (unless (block-loop succ) - (exits exit) - (return))))) - + (dolist (succ (block-succ exit)) + (unless (block-loop succ) + (exits exit) + (return))))) + (do ((block (loop-blocks loop) (block-loop-next block))) - ((null block)) + ((null block)) (dolist (succ (block-succ block)) - (unless (block-loop succ) - (exits block) - (return)))) + (unless (block-loop succ) + (exits block) + (return)))) (setf (loop-exits loop) (exits)))) @@ -134,7 +134,7 @@ ;;; recurse on its successors. (defun find-blocks-from-here (block loop) (when (and (not (block-loop block)) - (dominates-p (loop-head loop) block)) + (dominates-p (loop-head loop) block)) (setf (block-loop block) loop) (shiftf (block-loop-next block) (loop-blocks loop) block) (dolist (succ (block-succ block)) @@ -152,17 +152,17 @@ (let ((superior (find-superior head (component-outer-loop component)))) (unless (eq (loop-head superior) head) (let ((result (make-loop :head head - :kind :natural - :superior superior - :depth (1+ (loop-depth superior)))) - (number (block-number head))) - (push result (loop-inferiors superior)) - (dolist (pred (block-pred head)) - (when (<= (block-number pred) number) - (if (dominates-p head pred) - (push pred (loop-tail result)) - (setf (loop-kind result) :strange)))) - (eq (loop-kind result) :strange))))) + :kind :natural + :superior superior + :depth (1+ (loop-depth superior)))) + (number (block-number head))) + (push result (loop-inferiors superior)) + (dolist (pred (block-pred head)) + (when (<= (block-number pred) number) + (if (dominates-p head pred) + (push pred (loop-tail result)) + (setf (loop-kind result) :strange)))) + (eq (loop-kind result) :strange))))) ;;; FIND-SUPERIOR -- Internal @@ -174,8 +174,8 @@ (if (eq (loop-head loop) head) loop (dolist (inferior (loop-inferiors loop) loop) - (when (dominates-p (loop-head inferior) head) - (return (find-superior head inferior)))))) + (when (dominates-p (loop-head inferior) head) + (return (find-superior head inferior)))))) ;;; FIND-STRANGE-LOOP-BLOCKS -- Internal @@ -190,16 +190,16 @@ (defun find-strange-loop-blocks (block head) (let ((flag (block-flag block))) (cond (flag - (if (eq flag :good) - t - nil)) - (t - (setf (block-flag block) :bad) - (unless (dominates-p block head) - (dolist (succ (block-succ block)) - (when (find-strange-loop-blocks succ head) - (setf (block-flag block) :good)))) - (eq (block-flag block) :good))))) + (if (eq flag :good) + t + nil)) + (t + (setf (block-flag block) :bad) + (unless (dominates-p block head) + (dolist (succ (block-succ block)) + (when (find-strange-loop-blocks succ head) + (setf (block-flag block) :good)))) + (eq (block-flag block) :good))))) ;;; FIND-STRANGE-LOOP-SEGMENTS -- Internal ;;; @@ -212,7 +212,7 @@ (when (eq (block-flag block) :good) (setf (block-flag block) :done) (unless (every #'(lambda (x) (member (block-flag x) '(:good :done))) - (block-pred block)) + (block-pred block)) (note-loop-head block component)) (dolist (succ (block-succ block)) (find-strange-loop-segments succ component)))) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 619ebbc..b790f42 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -28,7 +28,7 @@ ;;; FIXME: Classic CMU CL went to some trouble to cache LTN-POLICY ;;; values in LTN-ANALYZE so that they didn't have to be recomputed on ;;; every block. I stripped that out (the whole DEFMACRO FROB thing) -;;; because I found it too confusing. Thus, it might be that the +;;; because I found it too confusing. Thus, it might be that the ;;; new uncached code spends an unreasonable amount of time in ;;; this lookup function. This function should be profiled, and if ;;; it's a significant contributor to runtime, we can cache it in @@ -41,16 +41,16 @@ (defun node-ltn-policy (node) (declare (type node node)) (policy node - (let ((eff-space (max space - ;; on the theory that if the code is - ;; smaller, it will take less time to - ;; compile (could lose if the smallest - ;; case is out of line, and must - ;; allocate many linkage registers): - compilation-speed))) - (if (zerop safety) - (if (>= speed eff-space) :fast :small) - (if (>= speed eff-space) :fast-safe :safe))))) + (let ((eff-space (max space + ;; on the theory that if the code is + ;; smaller, it will take less time to + ;; compile (could lose if the smallest + ;; case is out of line, and must + ;; allocate many linkage registers): + compilation-speed))) + (if (zerop safety) + (if (>= speed eff-space) :fast :small) + (if (>= speed eff-space) :fast-safe :safe))))) ;;; Return true if LTN-POLICY is a safe policy. (defun ltn-policy-safe-p (ltn-policy) @@ -92,11 +92,11 @@ (declare (type lvar lvar)) (let ((use (lvar-uses lvar))) (and (ref-p use) - (let ((leaf (ref-leaf use))) - (etypecase leaf - (lambda-var (if (null (lambda-var-sets leaf)) leaf nil)) - (constant (if (legal-immediate-constant-p leaf) leaf nil)) - ((or functional global-var) nil)))))) + (let ((leaf (ref-leaf use))) + (etypecase leaf + (lambda-var (if (null (lambda-var-sets leaf)) leaf nil)) + (constant (if (legal-immediate-constant-p leaf) leaf nil)) + ((or functional global-var) nil)))))) ;;; Annotate a normal single-value lvar. If its only use is a ref that ;;; we are allowed to delay the evaluation of, then we mark the lvar @@ -122,7 +122,7 @@ (defun annotate-ordinary-lvar (lvar) (declare (type lvar lvar)) (let ((info (make-ir2-lvar - (primitive-type (lvar-type lvar))))) + (primitive-type (lvar-type lvar))))) (setf (lvar-info lvar) info) (annotate-1-value-lvar lvar)) (values)) @@ -134,13 +134,13 @@ (declare (type lvar lvar)) (aver (not (lvar-dynamic-extent lvar))) (let* ((tn-ptype (primitive-type (lvar-type lvar))) - (info (make-ir2-lvar tn-ptype))) + (info (make-ir2-lvar tn-ptype))) (setf (lvar-info lvar) info) (let ((name (lvar-fun-name lvar t))) (if (and delay name) - (setf (ir2-lvar-kind info) :delayed) - (setf (ir2-lvar-locs info) - (list (make-normal-tn tn-ptype)))))) + (setf (ir2-lvar-kind info) :delayed) + (setf (ir2-lvar-locs info) + (list (make-normal-tn tn-ptype)))))) (ltn-annotate-casts lvar) (values)) @@ -153,15 +153,15 @@ (defun flush-full-call-tail-transfer (call) (declare (type basic-combination call)) (let ((tails (and (node-tail-p call) - (lambda-tail-set (node-home-lambda call))))) + (lambda-tail-set (node-home-lambda call))))) (when tails (cond ((eq (return-info-kind (tail-set-info tails)) :unknown) - (node-ends-block call) - (let ((block (node-block call))) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (component-tail (block-component block))))) - (t - (setf (node-tail-p call) nil))))) + (node-ends-block call) + (let ((block (node-block call))) + (unlink-blocks block (first (block-succ block))) + (link-blocks block (component-tail (block-component block))))) + (t + (setf (node-tail-p call) nil))))) (values)) ;;; We set the kind to :FULL or :FUNNY, depending on whether there is @@ -175,7 +175,7 @@ (defun ltn-default-call (call) (declare (type combination call)) (let ((kind (basic-combination-kind call)) - (info (basic-combination-fun-info call))) + (info (basic-combination-fun-info call))) (annotate-fun-lvar (basic-combination-fun call)) (dolist (arg (basic-combination-args call)) @@ -186,7 +186,7 @@ (cond ((and (eq kind :known) - (fun-info-p info) + (fun-info-p info) (fun-info-ir2-convert info)) (setf (basic-combination-info call) :funny) (setf (node-tail-p call) nil)) @@ -223,11 +223,11 @@ (ltn-annotate-casts lvar) (let* ((block (node-block (lvar-dest lvar))) - (use (lvar-uses lvar)) - (2block (block-info block))) + (use (lvar-uses lvar)) + (2block (block-info block))) (unless (and (not (listp use)) (eq (node-block use) block)) (setf (ir2-block-popped 2block) - (nconc (ir2-block-popped 2block) (list lvar))))) + (nconc (ir2-block-popped 2block) (list lvar))))) (values)) @@ -269,27 +269,27 @@ (defun ltn-analyze-return (node) (declare (type creturn node)) (let* ((lvar (return-result node)) - (fun (return-lambda node)) - (returns (tail-set-info (lambda-tail-set fun))) - (types (return-info-types returns))) + (fun (return-lambda node)) + (returns (tail-set-info (lambda-tail-set fun))) + (types (return-info-types returns))) (if (eq (return-info-count returns) :unknown) - (collect ((res *empty-type* values-type-union)) - (do-uses (use (return-result node)) - (unless (and (node-tail-p use) - (basic-combination-p use) - (member (basic-combination-info use) '(:local :full))) - (res (node-derived-type use)))) - - (let ((int (res))) - (multiple-value-bind (types kind) + (collect ((res *empty-type* values-type-union)) + (do-uses (use (return-result node)) + (unless (and (node-tail-p use) + (basic-combination-p use) + (member (basic-combination-info use) '(:local :full))) + (res (node-derived-type use)))) + + (let ((int (res))) + (multiple-value-bind (types kind) (if (eq int *empty-type*) (values nil :unknown) (values-types int)) - (if (eq kind :unknown) - (annotate-unknown-values-lvar lvar) - (annotate-fixed-values-lvar - lvar (mapcar #'primitive-type types)))))) - (annotate-fixed-values-lvar lvar types))) + (if (eq kind :unknown) + (annotate-unknown-values-lvar lvar) + (annotate-fixed-values-lvar + lvar (mapcar #'primitive-type types)))))) + (annotate-fixed-values-lvar lvar types))) (values)) @@ -304,9 +304,9 @@ (annotate-fixed-values-lvar (first (basic-combination-args call)) (mapcar (lambda (var) - (primitive-type (basic-var-type var))) - (lambda-vars - (ref-leaf (lvar-use (basic-combination-fun call)))))) + (primitive-type (basic-var-type var))) + (lambda-vars + (ref-leaf (lvar-use (basic-combination-fun call)))))) (values)) ;;; We force all the argument lvars to use the unknown values @@ -325,18 +325,18 @@ (defun ltn-analyze-mv-call (call) (declare (type mv-combination call)) (let ((fun (basic-combination-fun call)) - (args (basic-combination-args call))) + (args (basic-combination-args call))) (cond ((eq (lvar-fun-name fun) '%throw) - (setf (basic-combination-info call) :funny) - (annotate-ordinary-lvar (first args)) - (annotate-unknown-values-lvar (second args)) - (setf (node-tail-p call) nil)) - (t - (setf (basic-combination-info call) :full) - (annotate-fun-lvar (basic-combination-fun call) nil) - (dolist (arg (reverse args)) - (annotate-unknown-values-lvar arg)) - (flush-full-call-tail-transfer call)))) + (setf (basic-combination-info call) :funny) + (annotate-ordinary-lvar (first args)) + (annotate-unknown-values-lvar (second args)) + (setf (node-tail-p call) nil)) + (t + (setf (basic-combination-info call) :full) + (annotate-fun-lvar (basic-combination-fun call) nil) + (dolist (arg (reverse args)) + (annotate-unknown-values-lvar arg)) + (flush-full-call-tail-transfer call)))) (values)) @@ -358,9 +358,9 @@ ;;; weren't sure they would really be TR until now. (defun set-tail-local-call-successor (call) (let ((caller (node-home-lambda call)) - (callee (combination-lambda call))) + (callee (combination-lambda call))) (aver (eq (lambda-tail-set caller) - (lambda-tail-set (lambda-home callee)))) + (lambda-tail-set (lambda-home callee)))) (node-ends-block call) (let ((block (node-block call))) (unlink-blocks block (first (block-succ block))) @@ -384,11 +384,11 @@ (declare (type cif node)) (setf (node-tail-p node) nil) (let* ((test (if-test node)) - (use (lvar-uses test))) + (use (lvar-uses test))) (unless (and (combination-p use) - (let ((info (basic-combination-info use))) - (and (template-p info) - (eq (template-result-types info) :conditional)))) + (let ((info (basic-combination-info use))) + (and (template-p info) + (eq (template-result-types info) :conditional)))) (annotate-ordinary-lvar test))) (values)) @@ -410,8 +410,8 @@ ;;; converted the reference to the escape function into a constant ;;; reference to the NLX-INFO.) (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) - node - ltn-policy) + node + ltn-policy) ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil)) @@ -437,51 +437,51 @@ ;;; arguments. (defun operand-restriction-ok (restr type &key lvar tn (t-ok t)) (declare (type (or (member *) cons) restr) - (type primitive-type type) - (type (or lvar null) lvar) - (type (or tn null) tn)) + (type primitive-type type) + (type (or lvar null) lvar) + (type (or tn null) tn)) (if (eq restr '*) t (ecase (first restr) - (:or - (dolist (mem (rest restr) nil) - (when (or (and t-ok (eq mem *backend-t-primitive-type*)) - (eq mem type)) - (return t)))) - (:constant - (cond (lvar - (and (constant-lvar-p lvar) - (funcall (second restr) (lvar-value lvar)))) - (tn - (and (eq (tn-kind tn) :constant) - (funcall (second restr) (tn-value tn)))) - (t - (error "Neither LVAR nor TN supplied."))))))) + (:or + (dolist (mem (rest restr) nil) + (when (or (and t-ok (eq mem *backend-t-primitive-type*)) + (eq mem type)) + (return t)))) + (:constant + (cond (lvar + (and (constant-lvar-p lvar) + (funcall (second restr) (lvar-value lvar)))) + (tn + (and (eq (tn-kind tn) :constant) + (funcall (second restr) (tn-value tn)))) + (t + (error "Neither LVAR nor TN supplied."))))))) ;;; Check that the argument type restriction for TEMPLATE are ;;; satisfied in call. If an argument's TYPE-CHECK is :NO-CHECK and ;;; our policy is safe, then only :SAFE templates are OK. (defun template-args-ok (template call safe-p) (declare (type template template) - (type combination call)) + (type combination call)) (declare (ignore safe-p)) (let ((mtype (template-more-args-type template))) (do ((args (basic-combination-args call) (cdr args)) - (types (template-arg-types template) (cdr types))) - ((null types) - (cond ((null args) t) - ((not mtype) nil) - (t - (dolist (arg args t) - (unless (operand-restriction-ok mtype - (lvar-ptype arg)) - (return nil)))))) + (types (template-arg-types template) (cdr types))) + ((null types) + (cond ((null args) t) + ((not mtype) nil) + (t + (dolist (arg args t) + (unless (operand-restriction-ok mtype + (lvar-ptype arg)) + (return nil)))))) (when (null args) (return nil)) (let ((arg (car args)) - (type (car types))) - (unless (operand-restriction-ok type (lvar-ptype arg) - :lvar arg) - (return nil)))))) + (type (car types))) + (unless (operand-restriction-ok type (lvar-ptype arg) + :lvar arg) + (return nil)))))) ;;; Check that TEMPLATE can be used with the specifed RESULT-TYPE. ;;; Result type checking is pretty different from argument type @@ -493,25 +493,25 @@ ;;; we run out of result types, then we always win. (defun template-results-ok (template result-type) (declare (type template template) - (type ctype result-type)) + (type ctype result-type)) (when (template-more-results-type template) (error "~S has :MORE results with :TRANSLATE." (template-name template))) (let ((types (template-result-types template))) (cond ((values-type-p result-type) (do ((ltypes (append (args-type-required result-type) - (args-type-optional result-type)) - (rest ltypes)) - (types types (rest types))) - ((null ltypes) - (dolist (type types t) - (unless (eq type '*) - (return nil)))) - (when (null types) (return t)) - (let ((type (first types))) - (unless (operand-restriction-ok type - (primitive-type (first ltypes))) - (return nil))))) + (args-type-optional result-type)) + (rest ltypes)) + (types types (rest types))) + ((null ltypes) + (dolist (type types t) + (unless (eq type '*) + (return nil)))) + (when (null types) (return t)) + (let ((type (first types))) + (unless (operand-restriction-ok type + (primitive-type (first ltypes))) + (return nil))))) (types (operand-restriction-ok (first types) (primitive-type result-type))) (t t)))) @@ -535,25 +535,25 @@ (defun is-ok-template-use (template call safe-p) (declare (type template template) (type combination call)) (let* ((guard (template-guard template)) - (lvar (node-lvar call)) - (dtype (node-derived-type call))) + (lvar (node-lvar call)) + (dtype (node-derived-type call))) (cond ((and guard (not (funcall guard))) - (values nil :guard)) - ((not (template-args-ok template call safe-p)) - (values nil - (if (and safe-p (template-args-ok template call nil)) - :arg-check - :arg-types))) - ((eq (template-result-types template) :conditional) - (let ((dest (lvar-dest lvar))) - (if (and (if-p dest) - (immediately-used-p (if-test dest) call)) - (values t nil) - (values nil :conditional)))) - ((template-results-ok template dtype) - (values t nil)) - (t - (values nil :result-types))))) + (values nil :guard)) + ((not (template-args-ok template call safe-p)) + (values nil + (if (and safe-p (template-args-ok template call nil)) + :arg-check + :arg-types))) + ((eq (template-result-types template) :conditional) + (let ((dest (lvar-dest lvar))) + (if (and (if-p dest) + (immediately-used-p (if-test dest) call)) + (values t nil) + (values nil :conditional)))) + ((template-results-ok template dtype) + (values t nil)) + (t + (values nil :result-types))))) ;;; Use operand type information to choose a template from the list ;;; TEMPLATES for a known CALL. We return three values: @@ -571,7 +571,7 @@ (values nil rejected nil)) (let ((template (first templates))) (when (is-ok-template-use template call safe-p) - (return (values template rejected (rest templates)))) + (return (values template rejected (rest templates)))) (setq rejected template)))) ;;; Given a partially annotated known call and a translation policy, @@ -597,27 +597,27 @@ ;;; small and fast as well. (defun find-template-for-ltn-policy (call ltn-policy) (declare (type combination call) - (type ltn-policy ltn-policy)) + (type ltn-policy ltn-policy)) (let ((safe-p (ltn-policy-safe-p ltn-policy)) - (current (fun-info-templates (basic-combination-fun-info call))) - (fallback nil) - (rejected nil)) + (current (fun-info-templates (basic-combination-fun-info call))) + (fallback nil) + (rejected nil)) (loop (multiple-value-bind (template this-reject more) - (find-template current call safe-p) + (find-template current call safe-p) (unless rejected - (setq rejected this-reject)) + (setq rejected this-reject)) (setq current more) (unless template - (return (values fallback rejected))) + (return (values fallback rejected))) (let ((tcpolicy (template-ltn-policy template))) - (cond ((eq tcpolicy ltn-policy) - (return (values template rejected))) - ((eq tcpolicy :safe) - (return (values (or fallback template) rejected))) - ((or (not safe-p) (eq tcpolicy :fast-safe)) - (unless fallback - (setq fallback template))))))))) + (cond ((eq tcpolicy ltn-policy) + (return (values template rejected))) + ((eq tcpolicy :safe) + (return (values (or fallback template) rejected))) + ((or (not safe-p) (eq tcpolicy :fast-safe)) + (unless fallback + (setq fallback template))))))))) (defvar *efficiency-note-limit* 2 #!+sb-doc @@ -637,7 +637,7 @@ ;;; the VM definition is messed up somehow. (defun strange-template-failure (template call ltn-policy frob) (declare (type template template) (type combination call) - (type ltn-policy ltn-policy) (type function frob)) + (type ltn-policy ltn-policy) (type function frob)) (funcall frob "This shouldn't happen! Bug?") (multiple-value-bind (win why) (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) @@ -650,19 +650,19 @@ (:arg-types (funcall frob "argument types invalid") (funcall frob "argument primitive types:~% ~S" - (mapcar (lambda (x) - (primitive-type-name - (lvar-ptype x))) - (combination-args call))) + (mapcar (lambda (x) + (primitive-type-name + (lvar-ptype x))) + (combination-args call))) (funcall frob "argument type assertions:~% ~S" - (mapcar (lambda (x) - (if (atom x) - x - (ecase (car x) - (:or `(:or .,(mapcar #'primitive-type-name - (cdr x)))) - (:constant `(:constant ,(third x)))))) - (template-arg-types template)))) + (mapcar (lambda (x) + (if (atom x) + x + (ecase (car x) + (:or `(:or .,(mapcar #'primitive-type-name + (cdr x)))) + (:constant `(:constant ,(third x)))))) + (template-arg-types template)))) (:conditional (funcall frob "conditional in a non-conditional context")) (:result-types @@ -694,76 +694,76 @@ ;;; suppressed, etc. (defun note-rejected-templates (call ltn-policy template) (declare (type combination call) (type ltn-policy ltn-policy) - (type (or template null) template)) + (type (or template null) template)) (collect ((losers)) (let ((safe-p (ltn-policy-safe-p ltn-policy)) - (verbose-p (policy call (= inhibit-warnings 0))) - (max-cost (- (template-cost - (or template - (template-or-lose 'call-named))) - *efficiency-note-cost-threshold*))) + (verbose-p (policy call (= inhibit-warnings 0))) + (max-cost (- (template-cost + (or template + (template-or-lose 'call-named))) + *efficiency-note-cost-threshold*))) (dolist (try (fun-info-templates (basic-combination-fun-info call))) - (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner. - (let ((guard (template-guard try))) - (when (and (or (not guard) (funcall guard)) - (or (not safe-p) - (ltn-policy-safe-p (template-ltn-policy try))) + (when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner. + (let ((guard (template-guard try))) + (when (and (or (not guard) (funcall guard)) + (or (not safe-p) + (ltn-policy-safe-p (template-ltn-policy try))) ;; :SAFE is also considered to be :SMALL-SAFE, ;; while the template cost describes time cost; ;; so the fact that (< (t-cost try) (t-cost ;; template)) does not mean that TRY is better (not (and (eq ltn-policy :safe) (eq (template-ltn-policy try) :fast-safe))) - (or verbose-p - (and (template-note try) - (valid-fun-use - call (template-type try) - :argument-test #'types-equal-or-intersect - :result-test - #'values-types-equal-or-intersect)))) - (losers try))))) + (or verbose-p + (and (template-note try) + (valid-fun-use + call (template-type try) + :argument-test #'types-equal-or-intersect + :result-test + #'values-types-equal-or-intersect)))) + (losers try))))) (when (losers) (collect ((messages) - (notes 0 +)) - (flet ((lose1 (string &rest stuff) - (messages string) - (messages stuff))) - (dolist (loser (losers)) - (when (and *efficiency-note-limit* - (>= (notes) *efficiency-note-limit*)) - (lose1 "etc.") - (return)) - (let* ((type (template-type loser)) - (valid (valid-fun-use call type)) - (strict-valid (valid-fun-use call type))) - (lose1 "unable to do ~A (cost ~W) because:" - (or (template-note loser) (template-name loser)) - (template-cost loser)) - (cond - ((and valid strict-valid) - (strange-template-failure loser call ltn-policy #'lose1)) - ((not valid) - (aver (not (valid-fun-use call type - :lossage-fun #'lose1 - :unwinnage-fun #'lose1)))) - (t - (aver (ltn-policy-safe-p ltn-policy)) - (lose1 "can't trust output type assertion under safe policy"))) - (notes 1)))) - - (let ((*compiler-error-context* call)) - (compiler-notify "~{~?~^~&~6T~}" - (if template - `("forced to do ~A (cost ~W)" - (,(or (template-note template) - (template-name template)) - ,(template-cost template)) - . ,(messages)) - `("forced to do full call" - nil - . ,(messages)))))))) + (notes 0 +)) + (flet ((lose1 (string &rest stuff) + (messages string) + (messages stuff))) + (dolist (loser (losers)) + (when (and *efficiency-note-limit* + (>= (notes) *efficiency-note-limit*)) + (lose1 "etc.") + (return)) + (let* ((type (template-type loser)) + (valid (valid-fun-use call type)) + (strict-valid (valid-fun-use call type))) + (lose1 "unable to do ~A (cost ~W) because:" + (or (template-note loser) (template-name loser)) + (template-cost loser)) + (cond + ((and valid strict-valid) + (strange-template-failure loser call ltn-policy #'lose1)) + ((not valid) + (aver (not (valid-fun-use call type + :lossage-fun #'lose1 + :unwinnage-fun #'lose1)))) + (t + (aver (ltn-policy-safe-p ltn-policy)) + (lose1 "can't trust output type assertion under safe policy"))) + (notes 1)))) + + (let ((*compiler-error-context* call)) + (compiler-notify "~{~?~^~&~6T~}" + (if template + `("forced to do ~A (cost ~W)" + (,(or (template-note template) + (template-name template)) + ,(template-cost template)) + . ,(messages)) + `("forced to do full call" + nil + . ,(messages)))))))) (values)) ;;; If a function has a special-case annotation method use that, @@ -774,51 +774,51 @@ (declare (type combination call)) (let ((ltn-policy (node-ltn-policy call)) (method (fun-info-ltn-annotate (basic-combination-fun-info call))) - (args (basic-combination-args call))) + (args (basic-combination-args call))) (when method (funcall method call ltn-policy) (return-from ltn-analyze-known-call (values))) (dolist (arg args) (setf (lvar-info arg) - (make-ir2-lvar (primitive-type (lvar-type arg))))) + (make-ir2-lvar (primitive-type (lvar-type arg))))) (multiple-value-bind (template rejected) - (find-template-for-ltn-policy call ltn-policy) + (find-template-for-ltn-policy call ltn-policy) ;; If we are unable to use some templates due to unsatisfied ;; operand type restrictions and our policy enables efficiency ;; notes, then we call NOTE-REJECTED-TEMPLATES. (when (and rejected - (policy call (> speed inhibit-warnings))) - (note-rejected-templates call ltn-policy template)) + (policy call (> speed inhibit-warnings))) + (note-rejected-templates call ltn-policy template)) ;; If we are forced to do a full call, we check to see whether ;; the function called is the same as the current function. If ;; so, we give a warning, as this is probably a botched attempt ;; to implement an out-of-line version in terms of inline ;; transforms or VOPs or whatever. (unless template - (when (let ((funleaf (physenv-lambda (node-physenv call)))) - (and (leaf-has-source-name-p funleaf) - (eq (lvar-fun-name (combination-fun call)) - (leaf-source-name funleaf)) - (let ((info (basic-combination-fun-info call))) - (not (or (fun-info-ir2-convert info) - (ir1-attributep (fun-info-attributes info) - recursive)))))) - (let ((*compiler-error-context* call)) - (compiler-warn "~@" - (lexenv-policy (node-lexenv call)) - (mapcar (lambda (arg) - (type-specifier (lvar-type arg))) - args)))) - (ltn-default-call call) - (return-from ltn-analyze-known-call (values))) + (lexenv-policy (node-lexenv call)) + (mapcar (lambda (arg) + (type-specifier (lvar-type arg))) + args)))) + (ltn-default-call call) + (return-from ltn-analyze-known-call (values))) (setf (basic-combination-info call) template) (setf (node-tail-p call) nil) (dolist (arg args) - (annotate-1-value-lvar arg)))) + (annotate-1-value-lvar arg)))) (values)) @@ -874,17 +874,17 @@ ;;; past the block end in that case. (defun ltn-analyze-block (block) (do* ((node (block-start-node block) - (ctran-next ctran)) + (ctran-next ctran)) (ctran (node-next node) (node-next node))) (nil) (etypecase node (ref) (combination (ecase (basic-combination-kind node) - (:local (ltn-analyze-local-call node)) - ((:full :error) (ltn-default-call node)) - (:known - (ltn-analyze-known-call node)))) + (:local (ltn-analyze-local-call node)) + ((:full :error) (ltn-default-call node)) + (:known + (ltn-analyze-known-call node)))) (cif (ltn-analyze-if node)) (creturn (ltn-analyze-return node)) ((or bind entry)) @@ -893,10 +893,10 @@ (cast (ltn-analyze-cast node)) (mv-combination (ecase (basic-combination-kind node) - (:local - (ltn-analyze-mv-bind node)) - ((:full :error) - (ltn-analyze-mv-call node))))) + (:local + (ltn-analyze-mv-bind node)) + ((:full :error) + (ltn-analyze-mv-call node))))) (when (eq node (block-last block)) (return)))) @@ -917,13 +917,13 @@ (do-blocks (block component) (aver (not (block-info block))) (let ((2block (make-ir2-block block))) - (setf (block-info block) 2block) - (ltn-analyze-block block))) + (setf (block-info block) 2block) + (ltn-analyze-block block))) (do-blocks (block component) (let ((2block (block-info block))) - (let ((popped (ir2-block-popped 2block))) - (when popped - (push block (ir2-component-values-receivers 2comp))))))) + (let ((popped (ir2-block-popped 2block))) + (when popped + (push block (ir2-component-values-receivers 2comp))))))) (values)) ;;; This function is used to analyze blocks that must be added to the diff --git a/src/compiler/ltv.lisp b/src/compiler/ltv.lisp index 9ed48c8..4653dd9 100644 --- a/src/compiler/ltv.lisp +++ b/src/compiler/ltv.lisp @@ -22,27 +22,27 @@ storage." (if (producing-fasl-file) (multiple-value-bind (handle type) - (compile-load-time-value (if read-only-p - form - `(make-value-cell ,form))) - (declare (ignore type)) - (ir1-convert start next result - (if read-only-p - `(%load-time-value ',handle) - `(value-cell-ref (%load-time-value ',handle))))) + (compile-load-time-value (if read-only-p + form + `(make-value-cell ,form))) + (declare (ignore type)) + (ir1-convert start next result + (if read-only-p + `(%load-time-value ',handle) + `(value-cell-ref (%load-time-value ',handle))))) (let ((value - (handler-case (eval form) - (error (condition) - (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A" - condition))))) - (ir1-convert start next result - (if read-only-p - `',value - `(value-cell-ref ',(make-value-cell value))))))) + (handler-case (eval form) + (error (condition) + (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A" + condition))))) + (ir1-convert start next result + (if read-only-p + `',value + `(value-cell-ref ',(make-value-cell value))))))) (defoptimizer (%load-time-value ir2-convert) ((handle) node block) (aver (constant-lvar-p handle)) (let ((lvar (node-lvar node)) - (tn (make-load-time-value-tn (lvar-value handle) - *universal-type*))) + (tn (make-load-time-value-tn (lvar-value handle) + *universal-type*))) (move-lvar-result node block (list tn) lvar))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 7016312..d5110de 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -15,13 +15,13 @@ ;;; 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. +;;; 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. +;;; Retain expansion, but only use it opportunistically. (deftype inlinep () '(member :inline :maybe-inline :notinline nil)) ;;;; source-hacking defining forms @@ -35,43 +35,43 @@ ;;; result continuations for the resulting IR1. KIND is the function ;;; kind to associate with NAME. (defmacro def-ir1-translator (name (lambda-list start-var next-var result-var) - &body body) + &body body) (let ((fn-name (symbolicate "IR1-CONVERT-" name)) - (n-form (gensym)) - (n-env (gensym))) + (n-form (gensym)) + (n-env (gensym))) (multiple-value-bind (body decls doc) - (parse-defmacro lambda-list n-form body name "special form" - :environment n-env - :error-fun 'compiler-error + (parse-defmacro lambda-list n-form body name "special form" + :environment n-env + :error-fun 'compiler-error :wrap-block nil) `(progn - (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) - ,fn-name)) - (defun ,fn-name (,start-var ,next-var ,result-var ,n-form - &aux (,n-env *lexenv*)) - (declare (ignorable ,start-var ,next-var ,result-var)) - ,@decls - ,body - (values)) - ,@(when doc - `((setf (fdocumentation ',name 'function) ,doc))) - ;; FIXME: Evidently "there can only be one!" -- we overwrite any - ;; other :IR1-CONVERT value. This deserves a warning, I think. - (setf (info :function :ir1-convert ',name) #',fn-name) - ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to - ;; the 1990s? - (setf (info :function :kind ',name) :special-form) - ;; It's nice to do this for error checking in the target - ;; SBCL, but it's not nice to do this when we're running in - ;; the cross-compilation host Lisp, which owns the - ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. - #-sb-xc-host - (let ((fun (lambda (&rest rest) - (declare (ignore rest)) - (error 'special-form-function :name ',name)))) - (setf (%simple-fun-arglist fun) ',lambda-list) - (setf (symbol-function ',name) fun)) - ',name)))) + (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) + ,fn-name)) + (defun ,fn-name (,start-var ,next-var ,result-var ,n-form + &aux (,n-env *lexenv*)) + (declare (ignorable ,start-var ,next-var ,result-var)) + ,@decls + ,body + (values)) + ,@(when doc + `((setf (fdocumentation ',name 'function) ,doc))) + ;; FIXME: Evidently "there can only be one!" -- we overwrite any + ;; other :IR1-CONVERT value. This deserves a warning, I think. + (setf (info :function :ir1-convert ',name) #',fn-name) + ;; FIXME: rename this to SPECIAL-OPERATOR, to update it to + ;; the 1990s? + (setf (info :function :kind ',name) :special-form) + ;; It's nice to do this for error checking in the target + ;; SBCL, but it's not nice to do this when we're running in + ;; the cross-compilation host Lisp, which owns the + ;; SYMBOL-FUNCTION of its COMMON-LISP symbols. + #-sb-xc-host + (let ((fun (lambda (&rest rest) + (declare (ignore rest)) + (error 'special-form-function :name ',name)))) + (setf (%simple-fun-arglist fun) ',lambda-list) + (setf (symbol-function ',name) fun)) + ',name)))) ;;; (This is similar to DEF-IR1-TRANSLATOR, except that we pass if the ;;; syntax is invalid.) @@ -94,15 +94,15 @@ ;;; determine when to pass. (defmacro source-transform-lambda (lambda-list &body body) (let ((n-form (gensym)) - (n-env (gensym)) - (name (gensym))) + (n-env (gensym)) + (name (gensym))) (multiple-value-bind (body decls) - (parse-defmacro lambda-list n-form body "source transform" "form" - :environment n-env - :error-fun `(lambda (&rest stuff) - (declare (ignore stuff)) - (return-from ,name - (values nil t))) + (parse-defmacro lambda-list n-form body "source transform" "form" + :environment n-env + :error-fun `(lambda (&rest stuff) + (declare (ignore stuff)) + (return-from ,name + (values nil t))) :wrap-block nil) `(lambda (,n-form &aux (,n-env *lexenv*)) ,@decls @@ -128,9 +128,9 @@ (collect ((res 0 logior)) (dolist (name names) (let ((mask (cdr (assoc name alist)))) - (unless mask - (error "unknown attribute name: ~S" name)) - (res mask))) + (unless mask + (error "unknown attribute name: ~S" name)) + (res mask))) (res))) ) ; EVAL-WHEN @@ -152,33 +152,33 @@ (def!macro !def-boolean-attribute (name &rest attribute-names) (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*")) - (test-name (symbolicate name "-ATTRIBUTEP")) + (test-name (symbolicate name "-ATTRIBUTEP")) (decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES"))) (collect ((alist)) (do ((mask 1 (ash mask 1)) - (names attribute-names (cdr names))) - ((null names)) - (alist (cons (car names) mask))) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter ,translations-name ',(alist))) - (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names) - "Automagically generated boolean attribute creation function. + (names attribute-names (cdr names))) + ((null names)) + (alist (cons (car names) mask))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,translations-name ',(alist))) + (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names) + "Automagically generated boolean attribute creation function. See !DEF-BOOLEAN-ATTRIBUTE." - (compute-attribute-mask attribute-names ,translations-name)) - (defmacro ,test-name (attributes &rest attribute-names) - "Automagically generated boolean attribute test function. + (compute-attribute-mask attribute-names ,translations-name)) + (defmacro ,test-name (attributes &rest attribute-names) + "Automagically generated boolean attribute test function. See !DEF-BOOLEAN-ATTRIBUTE." - `(logtest ,(compute-attribute-mask attribute-names - ,translations-name) - (the attributes ,attributes))) - ;; This definition transforms strangely under UNCROSS, in a - ;; way that DEF!MACRO doesn't understand, so we delegate it - ;; to a submacro then define the submacro differently when - ;; building the xc and when building the target compiler. - (!def-boolean-attribute-setter ,test-name - ,translations-name - ,@attribute-names) + `(logtest ,(compute-attribute-mask attribute-names + ,translations-name) + (the attributes ,attributes))) + ;; This definition transforms strangely under UNCROSS, in a + ;; way that DEF!MACRO doesn't understand, so we delegate it + ;; to a submacro then define the submacro differently when + ;; building the xc and when building the target compiler. + (!def-boolean-attribute-setter ,test-name + ,translations-name + ,@attribute-names) (defun ,decoder-name (attributes) (loop for (name . mask) in ,translations-name when (logtest mask attributes) @@ -189,11 +189,11 @@ ;; hack it by hand, passing a different GET-SETF-EXPANSION-FUN-NAME ;; in the host DEFMACRO and target DEFMACRO-MUNDANELY cases. (defun guts-of-!def-boolean-attribute-setter (test-name - translations-name - attribute-names - get-setf-expansion-fun-name) + translations-name + attribute-names + get-setf-expansion-fun-name) `(define-setf-expander ,test-name (place &rest attributes - &environment env) + &environment env) "Automagically generated boolean attribute setter. See !DEF-BOOLEAN-ATTRIBUTE." #-sb-xc-host (declare (type sb!c::lexenv env)) @@ -201,35 +201,35 @@ ;; automatically declared to have type LEXENV by the ;; hairy-argument-handling code. (multiple-value-bind (temps values stores set get) - (,get-setf-expansion-fun-name place env) - (when (cdr stores) - (error "multiple store variables for ~S" place)) - (let ((newval (gensym)) - (n-place (gensym)) - (mask (compute-attribute-mask attributes ,translations-name))) - (values `(,@temps ,n-place) - `(,@values ,get) - `(,newval) - `(let ((,(first stores) - (if ,newval - (logior ,n-place ,mask) - (logand ,n-place ,(lognot mask))))) - ,set - ,newval) - `(,',test-name ,n-place ,@attributes)))))) + (,get-setf-expansion-fun-name place env) + (when (cdr stores) + (error "multiple store variables for ~S" place)) + (let ((newval (gensym)) + (n-place (gensym)) + (mask (compute-attribute-mask attributes ,translations-name))) + (values `(,@temps ,n-place) + `(,@values ,get) + `(,newval) + `(let ((,(first stores) + (if ,newval + (logior ,n-place ,mask) + (logand ,n-place ,(lognot mask))))) + ,set + ,newval) + `(,',test-name ,n-place ,@attributes)))))) ;; We define the host version here, and the just-like-it-but-different ;; target version later, after DEFMACRO-MUNDANELY has been defined. (defmacro !def-boolean-attribute-setter (test-name - translations-name - &rest attribute-names) + translations-name + &rest attribute-names) (guts-of-!def-boolean-attribute-setter test-name - translations-name - attribute-names - 'get-setf-expansion))) + translations-name + attribute-names + 'get-setf-expansion))) ;;; And now for some gratuitous pseudo-abstraction... ;;; -;;; ATTRIBUTES-UNION +;;; ATTRIBUTES-UNION ;;; Return the union of all the sets of boolean attributes which are its ;;; arguments. ;;; ATTRIBUTES-INTERSECTION @@ -240,10 +240,10 @@ ;;; those in ATTR2. (defmacro attributes-union (&rest attributes) `(the attributes - (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) + (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) (defmacro attributes-intersection (&rest attributes) `(the attributes - (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) + (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) (declaim (ftype (function (attributes attributes) boolean) attributes=)) #!-sb-fluid (declaim (inline attributes=)) (defun attributes= (attr1 attr2) @@ -272,60 +272,60 @@ (multiple-value-bind (req opt restp rest keyp keys allowp) (parse-lambda-list lambda-list) (let* ((min-args (length req)) - (max-args (+ min-args (length opt))) - (n-keys (gensym))) + (max-args (+ min-args (length opt))) + (n-keys (gensym))) (collect ((binds) - (vars) - (pos 0 +) - (keywords)) - (dolist (arg req) - (vars arg) - (binds `(,arg (nth ,(pos) ,args))) - (pos 1)) - - (dolist (arg opt) - (let ((var (if (atom arg) arg (first arg)))) - (vars var) - (binds `(,var (nth ,(pos) ,args))) - (pos 1))) - - (when restp - (vars rest) - (binds `(,rest (nthcdr ,(pos) ,args)))) - - (dolist (spec keys) - (if (or (atom spec) (atom (first spec))) - (let* ((var (if (atom spec) spec (first spec))) - (key (keywordicate var))) - (vars var) - (binds `(,var (find-keyword-lvar ,n-keys ,key))) - (keywords key)) - (let* ((head (first spec)) - (var (second head)) - (key (first head))) - (vars var) - (binds `(,var (find-keyword-lvar ,n-keys ,key))) - (keywords key)))) - - (let ((n-length (gensym)) - (limited-legal (not (or restp keyp)))) - (values - `(let ((,n-length (length ,args)) - ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args))))) - (unless (and - ;; FIXME: should be PROPER-LIST-OF-LENGTH-P - ,(if limited-legal - `(<= ,min-args ,n-length ,max-args) - `(<= ,min-args ,n-length)) - ,@(when keyp - (if allowp - `((check-key-args-constant ,n-keys)) - `((check-transform-keys ,n-keys ',(keywords)))))) - ,error-form) - (let ,(binds) - (declare (ignorable ,@(vars))) - ,@body)) - (vars))))))) + (vars) + (pos 0 +) + (keywords)) + (dolist (arg req) + (vars arg) + (binds `(,arg (nth ,(pos) ,args))) + (pos 1)) + + (dolist (arg opt) + (let ((var (if (atom arg) arg (first arg)))) + (vars var) + (binds `(,var (nth ,(pos) ,args))) + (pos 1))) + + (when restp + (vars rest) + (binds `(,rest (nthcdr ,(pos) ,args)))) + + (dolist (spec keys) + (if (or (atom spec) (atom (first spec))) + (let* ((var (if (atom spec) spec (first spec))) + (key (keywordicate var))) + (vars var) + (binds `(,var (find-keyword-lvar ,n-keys ,key))) + (keywords key)) + (let* ((head (first spec)) + (var (second head)) + (key (first head))) + (vars var) + (binds `(,var (find-keyword-lvar ,n-keys ,key))) + (keywords key)))) + + (let ((n-length (gensym)) + (limited-legal (not (or restp keyp)))) + (values + `(let ((,n-length (length ,args)) + ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args))))) + (unless (and + ;; FIXME: should be PROPER-LIST-OF-LENGTH-P + ,(if limited-legal + `(<= ,min-args ,n-length ,max-args) + `(<= ,min-args ,n-length)) + ,@(when keyp + (if allowp + `((check-key-args-constant ,n-keys)) + `((check-transform-keys ,n-keys ',(keywords)))))) + ,error-form) + (let ,(binds) + (declare (ignorable ,@(vars))) + ,@body)) + (vars))))))) ) ; EVAL-WHEN @@ -389,50 +389,50 @@ ;;; transform fails even if INHIBIT-WARNINGS=SPEED (but not if ;;; INHIBIT-WARNINGS>SPEED). (defmacro deftransform (name (lambda-list &optional (arg-types '*) - (result-type '*) - &key result policy node defun-only - eval-name important) - &body body-decls-doc) + (result-type '*) + &key result policy node defun-only + eval-name important) + &body body-decls-doc) (when (and eval-name defun-only) (error "can't specify both DEFUN-ONLY and EVAL-NAME")) (multiple-value-bind (body decls doc) (parse-body body-decls-doc) (let ((n-args (gensym)) - (n-node (or node (gensym))) - (n-decls (gensym)) - (n-lambda (gensym)) - (decls-body `(,@decls ,@body))) + (n-node (or node (gensym))) + (n-decls (gensym)) + (n-lambda (gensym)) + (decls-body `(,@decls ,@body))) (multiple-value-bind (parsed-form vars) - (parse-deftransform lambda-list - (if policy - `((unless (policy ,n-node ,policy) - (give-up-ir1-transform)) - ,@decls-body) - body) - n-args - '(give-up-ir1-transform)) - (let ((stuff - `((,n-node) - (let* ((,n-args (basic-combination-args ,n-node)) - ,@(when result - `((,result (node-lvar ,n-node))))) - (multiple-value-bind (,n-lambda ,n-decls) - ,parsed-form - (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda)) - ,n-lambda - `(lambda ,',lambda-list - (declare (ignorable ,@',vars)) - ,@,n-decls - ,,n-lambda))))))) - (if defun-only - `(defun ,name ,@(when doc `(,doc)) ,@stuff) - `(%deftransform - ,(if eval-name name `',name) - ,(if eval-name - ``(function ,,arg-types ,,result-type) - `'(function ,arg-types ,result-type)) - (lambda ,@stuff) - ,doc - ,(if important t nil)))))))) + (parse-deftransform lambda-list + (if policy + `((unless (policy ,n-node ,policy) + (give-up-ir1-transform)) + ,@decls-body) + body) + n-args + '(give-up-ir1-transform)) + (let ((stuff + `((,n-node) + (let* ((,n-args (basic-combination-args ,n-node)) + ,@(when result + `((,result (node-lvar ,n-node))))) + (multiple-value-bind (,n-lambda ,n-decls) + ,parsed-form + (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda)) + ,n-lambda + `(lambda ,',lambda-list + (declare (ignorable ,@',vars)) + ,@,n-decls + ,,n-lambda))))))) + (if defun-only + `(defun ,name ,@(when doc `(,doc)) ,@stuff) + `(%deftransform + ,(if eval-name name `',name) + ,(if eval-name + ``(function ,,arg-types ,,result-type) + `'(function ,arg-types ,result-type)) + (lambda ,@stuff) + ,doc + ,(if important t nil)))))))) ;;;; DEFKNOWN and DEFOPTIMIZER @@ -457,7 +457,7 @@ (defmacro defknown (name arg-types result-type &optional (attributes '(any)) &rest keys) (when (and (intersection attributes '(any call unwind)) - (intersection attributes '(movable))) + (intersection attributes '(movable))) (error "function cannot have both good and bad attributes: ~S" attributes)) (when (member 'any attributes) @@ -466,12 +466,12 @@ (pushnew 'unsafely-flushable attributes)) `(%defknown ',(if (and (consp name) - (not (legal-fun-name-p name))) - name - (list name)) - '(sfunction ,arg-types ,result-type) - (ir1-attributes ,@attributes) - ,@keys)) + (not (legal-fun-name-p name))) + name + (list name)) + '(sfunction ,arg-types ,result-type) + (ir1-attributes ,@attributes) + ,@keys)) ;;; Create a function which parses combination args according to WHAT ;;; and LAMBDA-LIST, where WHAT is either a function name or a list @@ -495,23 +495,23 @@ ;;; methods are passed an additional POLICY argument, and IR2-CONVERT ;;; methods are passed an additional IR2-BLOCK argument. (defmacro defoptimizer (what (lambda-list &optional (n-node (gensym)) - &rest vars) - &body body) + &rest vars) + &body body) (let ((name (if (symbolp what) what - (symbolicate (first what) "-" (second what) "-OPTIMIZER")))) + (symbolicate (first what) "-" (second what) "-OPTIMIZER")))) (let ((n-args (gensym))) `(progn - (defun ,name (,n-node ,@vars) - (declare (ignorable ,@vars)) - (let ((,n-args (basic-combination-args ,n-node))) - ,(parse-deftransform lambda-list body n-args - `(return-from ,name nil)))) - ,@(when (consp what) - `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info))) + (defun ,name (,n-node ,@vars) + (declare (ignorable ,@vars)) + (let ((,n-args (basic-combination-args ,n-node))) + ,(parse-deftransform lambda-list body n-args + `(return-from ,name nil)))) + ,@(when (consp what) + `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info))) (symbolicate "FUN-INFO-" (second what))) - (fun-info-or-lose ',(first what))) - #',name))))))) + (fun-info-or-lose ',(first what))) + #',name))))))) ;;;; IR groveling macros @@ -528,33 +528,33 @@ (unless (member ends '(nil :head :tail :both)) (error "losing ENDS value: ~S" ends)) (let ((n-component (gensym)) - (n-tail (gensym))) + (n-tail (gensym))) `(let* ((,n-component ,component) - (,n-tail ,(if (member ends '(:both :tail)) - nil - `(component-tail ,n-component)))) + (,n-tail ,(if (member ends '(:both :tail)) + nil + `(component-tail ,n-component)))) (do ((,block-var ,(if (member ends '(:both :head)) - `(component-head ,n-component) - `(block-next (component-head ,n-component))) - (block-next ,block-var))) - ((eq ,block-var ,n-tail) ,result) - ,@body)))) + `(component-head ,n-component) + `(block-next (component-head ,n-component))) + (block-next ,block-var))) + ((eq ,block-var ,n-tail) ,result) + ,@body)))) ;;; like DO-BLOCKS, only iterating over the blocks in reverse order (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body) (unless (member ends '(nil :head :tail :both)) (error "losing ENDS value: ~S" ends)) (let ((n-component (gensym)) - (n-head (gensym))) + (n-head (gensym))) `(let* ((,n-component ,component) - (,n-head ,(if (member ends '(:both :head)) - nil - `(component-head ,n-component)))) + (,n-head ,(if (member ends '(:both :head)) + nil + `(component-head ,n-component)))) (do ((,block-var ,(if (member ends '(:both :tail)) - `(component-tail ,n-component) - `(block-prev (component-tail ,n-component))) - (block-prev ,block-var))) - ((eq ,block-var ,n-head) ,result) - ,@body)))) + `(component-tail ,n-component) + `(block-prev (component-tail ,n-component))) + (block-prev ,block-var))) + ((eq ,block-var ,n-head) ,result) + ,@body)))) ;;; Iterate over the uses of LVAR, binding NODE to each one ;;; successively. @@ -613,9 +613,9 @@ (t (return))))) ,@(when lvar-var `((,lvar-var (when (valued-node-p ,node-var) - (node-lvar ,node-var)) - (when (valued-node-p ,node-var) - (node-lvar ,node-var)))))) + (node-lvar ,node-var)) + (when (valued-node-p ,node-var) + (node-lvar ,node-var)))))) (nil) ,@body ,@(when restart-p @@ -626,7 +626,7 @@ ;;; with block being split under us. (defmacro do-nodes-backwards ((node-var lvar block &key restart-p) &body body) (let ((n-block (gensym)) - (n-prev (gensym))) + (n-prev (gensym))) `(loop with ,n-block = ,block for ,node-var = (block-last ,n-block) then ,(if restart-p @@ -636,7 +636,7 @@ `(ctran-use ,n-prev)) for ,n-prev = (when ,node-var (node-prev ,node-var)) and ,lvar = (when (and ,node-var (valued-node-p ,node-var)) - (node-lvar ,node-var)) + (node-lvar ,node-var)) while ,(if restart-p `(and ,node-var (not (block-to-be-deleted-p ,n-block))) node-var) @@ -656,15 +656,15 @@ ;;; after the original conversion pass has finished. (defmacro with-ir1-environment-from-node (node &rest forms) `(flet ((closure-needing-ir1-environment-from-node () - ,@forms)) + ,@forms)) (%with-ir1-environment-from-node ,node #'closure-needing-ir1-environment-from-node))) (defun %with-ir1-environment-from-node (node fun) (declare (type node node) (type function fun)) (let ((*current-component* (node-component node)) - (*lexenv* (node-lexenv node)) - (*current-path* (node-source-path node))) + (*lexenv* (node-lexenv node)) + (*current-path* (node-source-path node))) (aver-live-component *current-component*) (funcall fun))) @@ -672,12 +672,12 @@ ;;; functions, etc. Also establish condition handlers. (defmacro with-ir1-namespace (&body forms) `(let ((*free-vars* (make-hash-table :test 'eq)) - (*free-funs* (make-hash-table :test 'equal)) - (*constants* (make-hash-table :test 'equal)) - (*source-paths* (make-hash-table :test 'eq))) + (*free-funs* (make-hash-table :test 'equal)) + (*constants* (make-hash-table :test 'equal)) + (*source-paths* (make-hash-table :test 'eq))) (handler-bind ((compiler-error #'compiler-error-handler) - (style-warning #'compiler-style-warning-handler) - (warning #'compiler-warning-handler)) + (style-warning #'compiler-style-warning-handler) + (warning #'compiler-warning-handler)) ,@forms))) ;;; Look up NAME in the lexical environment namespace designated by @@ -688,10 +688,10 @@ (once-only ((n-res `(assoc ,name (,(let ((*package* (symbol-package 'lexenv-funs))) (symbolicate "LEXENV-" slot)) *lexenv*) - :test ,(or test '#'eq)))) + :test ,(or test '#'eq)))) `(if ,n-res - (values (cdr ,n-res) t) - (values nil nil)))) + (values (cdr ,n-res) t) + (values nil nil)))) (defmacro with-component-last-block ((component block) &body body) (with-unique-names (old-last-block) @@ -755,10 +755,10 @@ (defun event-action (name) (event-info-action (event-info-or-lose name))) (declaim (ftype (function (symbol (or function null)) (or function null)) - %set-event-action)) + %set-event-action)) (defun %set-event-action (name new-value) (setf (event-info-action (event-info-or-lose name)) - new-value)) + new-value)) (defsetf event-action %set-event-action) ;;; Return the non-negative integer which represents the level of @@ -771,7 +771,7 @@ (declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level)) (defun %set-event-level (name new-value) (setf (event-info-level (event-info-or-lose name)) - new-value)) + new-value)) (defsetf event-level %set-event-level) ;;; Define a new kind of event. NAME is a symbol which names the event @@ -783,10 +783,10 @@ (let ((var-name (symbolicate "*" name "-EVENT-INFO*"))) `(eval-when (:compile-toplevel :load-toplevel :execute) (defvar ,var-name - (make-event-info :name ',name - :description ',description - :var ',var-name - :level ,level)) + (make-event-info :name ',name + :description ',description + :var ',var-name + :level ,level)) (setf (gethash ',name *event-info*) ,var-name) ',name))) @@ -808,22 +808,22 @@ (defun event-statistics (&optional (min-count 1) (stream *standard-output*)) (collect ((info)) (maphash (lambda (k v) - (declare (ignore k)) - (when (>= (event-info-count v) min-count) - (info v))) - *event-info*) + (declare (ignore k)) + (when (>= (event-info-count v) min-count) + (info v))) + *event-info*) (dolist (event (sort (info) #'> :key #'event-info-count)) (format stream "~6D: ~A~%" (event-info-count event) - (event-info-description event))) + (event-info-description event))) (values)) (values)) (declaim (ftype (function nil (values)) clear-event-statistics)) (defun clear-event-statistics () (maphash (lambda (k v) - (declare (ignore k)) - (setf (event-info-count v) 0)) - *event-info*) + (declare (ignore k)) + (setf (event-info-count v) 0)) + *event-info*) (values)) ;;;; functions on directly-linked lists (linked through specialized @@ -835,49 +835,49 @@ ;;; function NEXT. KEY, TEST and TEST-NOT are the same as for generic ;;; sequence functions. (defun find-in (next - element - list - &key - (key #'identity) - (test #'eql test-p) - (test-not #'eql not-p)) + element + list + &key + (key #'identity) + (test #'eql test-p) + (test-not #'eql not-p)) (declare (type function next key test test-not)) (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p (do ((current list (funcall next current))) - ((null current) nil) - (unless (funcall test-not (funcall key current) element) - (return current))) + ((null current) nil) + (unless (funcall test-not (funcall key current) element) + (return current))) (do ((current list (funcall next current))) - ((null current) nil) - (when (funcall test (funcall key current) element) - (return current))))) + ((null current) nil) + (when (funcall test (funcall key current) element) + (return current))))) ;;; Return the position of ELEMENT (or NIL if absent) in a ;;; null-terminated LIST linked by the accessor function NEXT. KEY, ;;; TEST and TEST-NOT are the same as for generic sequence functions. (defun position-in (next - element - list - &key - (key #'identity) - (test #'eql test-p) - (test-not #'eql not-p)) + element + list + &key + (key #'identity) + (test #'eql test-p) + (test-not #'eql not-p)) (declare (type function next key test test-not)) (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p (do ((current list (funcall next current)) - (i 0 (1+ i))) - ((null current) nil) - (unless (funcall test-not (funcall key current) element) - (return i))) + (i 0 (1+ i))) + ((null current) nil) + (unless (funcall test-not (funcall key current) element) + (return i))) (do ((current list (funcall next current)) - (i 0 (1+ i))) - ((null current) nil) - (when (funcall test (funcall key current) element) - (return i))))) + (i 0 (1+ i))) + ((null current) nil) + (when (funcall test (funcall key current) element) + (return i))))) ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a @@ -897,22 +897,22 @@ (when (cdr stores) (error "multiple store variables for ~S" place)) (let ((n-item (gensym)) - (n-place (gensym)) - (n-current (gensym)) - (n-prev (gensym))) + (n-place (gensym)) + (n-current (gensym)) + (n-prev (gensym))) `(let* (,@(mapcar #'list temps vals) - (,n-place ,access) - (,n-item ,item)) - (if (eq ,n-place ,n-item) - (let ((,(first stores) (,next ,n-place))) - ,store) - (do ((,n-prev ,n-place ,n-current) - (,n-current (,next ,n-place) - (,next ,n-current))) - ((eq ,n-current ,n-item) - (setf (,next ,n-prev) - (,next ,n-current))))) - (values))))) + (,n-place ,access) + (,n-item ,item)) + (if (eq ,n-place ,n-item) + (let ((,(first stores) (,next ,n-place))) + ,store) + (do ((,n-prev ,n-place ,n-current) + (,n-current (,next ,n-place) + (,next ,n-current))) + ((eq ,n-current ,n-item) + (setf (,next ,n-prev) + (,next ,n-current))))) + (values))))) ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806 ;;; Push ITEM onto a list linked by the accessor function NEXT that is @@ -935,7 +935,7 @@ (when (cdr stores) (error "multiple store variables for ~S" place)) `(let (,@(mapcar #'list temps vals) - (,(first stores) ,item)) + (,(first stores) ,item)) (setf (,next ,(first stores)) ,access) ,store (values)))) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 33555ef..c7d814c 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -15,20 +15,20 @@ ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp? (declaim (special *constants* *free-vars* *component-being-compiled* - *code-vector* *next-location* *result-fixups* - *free-funs* *source-paths* - *seen-blocks* *seen-funs* *list-conflicts-table* - *continuation-number* *continuation-numbers* - *number-continuations* *tn-id* *tn-ids* *id-tns* - *label-ids* *label-id* *id-labels* - *undefined-warnings* *compiler-error-count* - *compiler-warning-count* *compiler-style-warning-count* - *compiler-note-count* - *compiler-error-bailout* - #!+sb-show *compiler-trace-output* - *last-source-context* *last-original-source* - *last-source-form* *last-format-string* *last-format-args* - *last-message-count* *lexenv* *fun-names-in-this-file* + *code-vector* *next-location* *result-fixups* + *free-funs* *source-paths* + *seen-blocks* *seen-funs* *list-conflicts-table* + *continuation-number* *continuation-numbers* + *number-continuations* *tn-id* *tn-ids* *id-tns* + *label-ids* *label-id* *id-labels* + *undefined-warnings* *compiler-error-count* + *compiler-warning-count* *compiler-style-warning-count* + *compiler-note-count* + *compiler-error-bailout* + #!+sb-show *compiler-trace-output* + *last-source-context* *last-original-source* + *last-source-form* *last-format-string* *last-format-args* + *last-message-count* *lexenv* *fun-names-in-this-file* *allow-instrumenting*)) ;;; Whether call of a function which cannot be defined causes a full @@ -38,7 +38,7 @@ (defvar *check-consistency* nil) (defvar *all-components*) -;;; Set to NIL to disable loop analysis for register allocation. +;;; Set to NIL to disable loop analysis for register allocation. (defvar *loop-analyze* t) ;;; Bind this to a stream to capture various internal debugging output. @@ -87,8 +87,8 @@ compiling.") (declaim (type (or pathname null) - sb!xc:*compile-file-pathname* - sb!xc:*compile-file-truename*)) + sb!xc:*compile-file-pathname* + sb!xc:*compile-file-truename*)) ;;; the SOURCE-INFO structure for the current compilation. This is ;;; null globally to indicate that we aren't currently in any @@ -137,7 +137,7 @@ information of functions compiled in within the dynamic contour. Primarily for use by development environments, in order to eg. associate function definitions with editor-buffers. Can be accessed as - SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested + SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested WITH-COMPILATION-UNITs provide :SOURCE-PLISTs, they are appended togather, innermost left. If Unaffected by :OVERRIDE." `(%with-compilation-unit (lambda () ,@body) ,@options)) @@ -147,32 +147,32 @@ (defun %with-compilation-unit (fn &key override source-plist) (declare (type function fn)) (let ((succeeded-p nil) - (*source-plist* (append source-plist *source-plist*))) + (*source-plist* (append source-plist *source-plist*))) (if (and *in-compilation-unit* (not override)) - ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is - ;; ordinarily (unless OVERRIDE) basically a no-op. - (unwind-protect - (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) - (unless succeeded-p - (incf *aborted-compilation-unit-count*))) - (let ((*aborted-compilation-unit-count* 0) - (*compiler-error-count* 0) - (*compiler-warning-count* 0) - (*compiler-style-warning-count* 0) - (*compiler-note-count* 0) - (*undefined-warnings* nil) - (*in-compilation-unit* t)) - (sb!thread:with-recursive-lock (*big-compiler-lock*) - (handler-bind ((parse-unknown-type - (lambda (c) - (note-undefined-reference - (parse-unknown-type-specifier c) - :type)))) - (unwind-protect - (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) - (unless succeeded-p - (incf *aborted-compilation-unit-count*)) - (summarize-compilation-unit (not succeeded-p))))))))) + ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is + ;; ordinarily (unless OVERRIDE) basically a no-op. + (unwind-protect + (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) + (unless succeeded-p + (incf *aborted-compilation-unit-count*))) + (let ((*aborted-compilation-unit-count* 0) + (*compiler-error-count* 0) + (*compiler-warning-count* 0) + (*compiler-style-warning-count* 0) + (*compiler-note-count* 0) + (*undefined-warnings* nil) + (*in-compilation-unit* t)) + (sb!thread:with-recursive-lock (*big-compiler-lock*) + (handler-bind ((parse-unknown-type + (lambda (c) + (note-undefined-reference + (parse-unknown-type-specifier c) + :type)))) + (unwind-protect + (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) + (unless succeeded-p + (incf *aborted-compilation-unit-count*)) + (summarize-compilation-unit (not succeeded-p))))))))) ;;; Is FUN-NAME something that no conforming program can rely on ;;; defining as a function? @@ -188,74 +188,74 @@ (defun summarize-compilation-unit (abort-p) (unless abort-p (handler-bind ((style-warning #'compiler-style-warning-handler) - (warning #'compiler-warning-handler)) + (warning #'compiler-warning-handler)) (let ((undefs (sort *undefined-warnings* #'string< - :key (lambda (x) - (let ((x (undefined-warning-name x))) - (if (symbolp x) - (symbol-name x) - (prin1-to-string x))))))) - (dolist (undef undefs) - (let ((name (undefined-warning-name undef)) - (kind (undefined-warning-kind undef)) - (warnings (undefined-warning-warnings undef)) - (undefined-warning-count (undefined-warning-count undef))) - (dolist (*compiler-error-context* warnings) + :key (lambda (x) + (let ((x (undefined-warning-name x))) + (if (symbolp x) + (symbol-name x) + (prin1-to-string x))))))) + (dolist (undef undefs) + (let ((name (undefined-warning-name undef)) + (kind (undefined-warning-kind undef)) + (warnings (undefined-warning-warnings undef)) + (undefined-warning-count (undefined-warning-count undef))) + (dolist (*compiler-error-context* warnings) (if #-sb-xc-host (and (eq kind :function) - (fun-name-reserved-by-ansi-p name) + (fun-name-reserved-by-ansi-p name) *flame-on-necessarily-undefined-function*) #+sb-xc-host nil - (case name - ((declare) - (compiler-warn - "~@" - name name)) - (t - (compiler-warn - "~@" - kind name))) - (if (eq kind :variable) - (compiler-warn "undefined ~(~A~): ~S" kind name) - (compiler-style-warn "undefined ~(~A~): ~S" kind name)))) - (let ((warn-count (length warnings))) - (when (and warnings (> undefined-warning-count warn-count)) - (let ((more (- undefined-warning-count warn-count))) - (if (eq kind :variable) - (compiler-warn - "~W more use~:P of undefined ~(~A~) ~S" - more kind name) - (compiler-style-warn - "~W more use~:P of undefined ~(~A~) ~S" - more kind name))))))) - - (dolist (kind '(:variable :function :type)) - (let ((summary (mapcar #'undefined-warning-name - (remove kind undefs :test #'neq - :key #'undefined-warning-kind)))) - (when summary - (if (eq kind :variable) - (compiler-warn + kind name))) + (if (eq kind :variable) + (compiler-warn "undefined ~(~A~): ~S" kind name) + (compiler-style-warn "undefined ~(~A~): ~S" kind name)))) + (let ((warn-count (length warnings))) + (when (and warnings (> undefined-warning-count warn-count)) + (let ((more (- undefined-warning-count warn-count))) + (if (eq kind :variable) + (compiler-warn + "~W more use~:P of undefined ~(~A~) ~S" + more kind name) + (compiler-style-warn + "~W more use~:P of undefined ~(~A~) ~S" + more kind name))))))) + + (dolist (kind '(:variable :function :type)) + (let ((summary (mapcar #'undefined-warning-name + (remove kind undefs :test #'neq + :key #'undefined-warning-kind)))) + (when summary + (if (eq kind :variable) + (compiler-warn "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ ~% ~{~<~% ~1:;~S~>~^ ~}" - (cdr summary) kind summary) - (compiler-style-warn + (cdr summary) kind summary) + (compiler-style-warn "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ ~% ~{~<~% ~1:;~S~>~^ ~}" - (cdr summary) kind summary)))))))) + (cdr summary) kind summary)))))))) (unless (and (not abort-p) - (zerop *aborted-compilation-unit-count*) - (zerop *compiler-error-count*) - (zerop *compiler-warning-count*) - (zerop *compiler-style-warning-count*) - (zerop *compiler-note-count*)) + (zerop *aborted-compilation-unit-count*) + (zerop *compiler-error-count*) + (zerop *compiler-warning-count*) + (zerop *compiler-style-warning-count*) + (zerop *compiler-note-count*)) (pprint-logical-block (*error-output* nil :per-line-prefix "; ") (format *error-output* "~&compilation unit ~:[finished~;aborted~]~ ~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~ @@ -263,12 +263,12 @@ ~[~:;~:*~& caught ~W WARNING condition~:P~]~ ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~ ~[~:;~:*~& printed ~W note~:P~]" - abort-p - *aborted-compilation-unit-count* - *compiler-error-count* - *compiler-warning-count* - *compiler-style-warning-count* - *compiler-note-count*)) + abort-p + *aborted-compilation-unit-count* + *compiler-error-count* + *compiler-warning-count* + *compiler-style-warning-count* + *compiler-note-count*)) (terpri *error-output*) (force-output *error-output*))) @@ -279,10 +279,10 @@ (defmacro with-compilation-values (&body body) `(with-ir1-namespace (let ((*warnings-p* nil) - (*failure-p* nil)) + (*failure-p* nil)) (values (progn ,@body) - *warnings-p* - *failure-p*)))) + *warnings-p* + *failure-p*)))) ;;;; component compilation @@ -304,13 +304,13 @@ (maybe-mumble "opt") (event ir1-optimize-until-done) (let ((count 0) - (cleared-reanalyze nil) + (cleared-reanalyze nil) (fastp nil)) (loop (when (component-reanalyze component) - (setq count 0) - (setq cleared-reanalyze t) - (setf (component-reanalyze component) nil)) + (setq count 0) + (setq cleared-reanalyze t) + (setf (component-reanalyze component) nil)) (setf (component-reoptimize component) nil) (ir1-optimize component fastp) (cond ((component-reoptimize component) @@ -320,20 +320,20 @@ (eq (component-reoptimize component) :maybe)) (maybe-mumble "*") (cond ((retry-delayed-ir1-transforms :optimize) - (maybe-mumble "+") - (setq count 0)) + (maybe-mumble "+") + (setq count 0)) (t - (event ir1-optimize-maxed-out) - (setf (component-reoptimize component) nil) - (do-blocks (block component) - (setf (block-reoptimize block) nil)) - (return))))) + (event ir1-optimize-maxed-out) + (setf (component-reoptimize component) nil) + (do-blocks (block component) + (setf (block-reoptimize block) nil)) + (return))))) ((retry-delayed-ir1-transforms :optimize) - (setf count 0) - (maybe-mumble "+")) - (t + (setf count 0) + (maybe-mumble "+")) + (t (maybe-mumble " ") - (return))) + (return))) (setq fastp (>= count *max-optimize-iterations*)) (maybe-mumble (if fastp "-" "."))) (when cleared-reanalyze @@ -364,8 +364,8 @@ (loop (find-dfo component) (unless (component-reanalyze component) - (maybe-mumble " ") - (return)) + (maybe-mumble " ") + (return)) (maybe-mumble "."))) (values)) @@ -374,39 +374,39 @@ (declare (type component component)) (aver-live-component component) (let ((*constraint-number* 0) - (loop-count 1) + (loop-count 1) (*delayed-ir1-transforms* nil)) (declare (special *constraint-number* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) (when (or (component-new-functionals component) - (component-reanalyze-functionals component)) - (maybe-mumble "locall ") - (locall-analyze-component component)) + (component-reanalyze-functionals component)) + (maybe-mumble "locall ") + (locall-analyze-component component)) (dfo-as-needed component) (when *constraint-propagate* - (maybe-mumble "constraint ") - (constraint-propagate component)) + (maybe-mumble "constraint ") + (constraint-propagate component)) (when (retry-delayed-ir1-transforms :constraint) (maybe-mumble "Rtran ")) (flet ((want-reoptimization-p () - (or (component-reoptimize component) - (component-reanalyze component) - (component-new-functionals component) - (component-reanalyze-functionals component)))) - (unless (and (want-reoptimization-p) - ;; We delay the generation of type checks until - ;; the type constraints have had time to - ;; propagate, else the compiler can confuse itself. - (< loop-count (- *reoptimize-after-type-check-max* 4))) - (maybe-mumble "type ") - (generate-type-checks component) - (unless (want-reoptimization-p) - (return)))) + (or (component-reoptimize component) + (component-reanalyze component) + (component-new-functionals component) + (component-reanalyze-functionals component)))) + (unless (and (want-reoptimization-p) + ;; We delay the generation of type checks until + ;; the type constraints have had time to + ;; propagate, else the compiler can confuse itself. + (< loop-count (- *reoptimize-after-type-check-max* 4))) + (maybe-mumble "type ") + (generate-type-checks component) + (unless (want-reoptimization-p) + (return)))) (when (>= loop-count *reoptimize-after-type-check-max*) - (maybe-mumble "[reoptimize limit]") - (event reoptimize-maxed-out) - (return)) + (maybe-mumble "[reoptimize limit]") + (event reoptimize-maxed-out) + (return)) (incf loop-count))) (ir1-finalize component) @@ -414,7 +414,7 @@ (defun %compile-component (component) (let ((*code-segment* nil) - (*elsewhere* nil)) + (*elsewhere* nil)) (maybe-mumble "GTN ") (gtn-analyze component) (maybe-mumble "LTN ") @@ -433,75 +433,75 @@ (dfo-as-needed component)) (unwind-protect - (progn - (maybe-mumble "IR2tran ") - (init-assembler) - (entry-analyze component) - (ir2-convert component) + (progn + (maybe-mumble "IR2tran ") + (init-assembler) + (entry-analyze component) + (ir2-convert component) - (when (policy *lexenv* (>= speed compilation-speed)) - (maybe-mumble "copy ") - (copy-propagate component)) + (when (policy *lexenv* (>= speed compilation-speed)) + (maybe-mumble "copy ") + (copy-propagate component)) - (select-representations component) + (select-representations component) - (when *check-consistency* - (maybe-mumble "check2 ") - (check-ir2-consistency component)) + (when *check-consistency* + (maybe-mumble "check2 ") + (check-ir2-consistency component)) - (delete-unreferenced-tns component) + (delete-unreferenced-tns component) - (maybe-mumble "life ") - (lifetime-analyze component) + (maybe-mumble "life ") + (lifetime-analyze component) - (when *compile-progress* - (compiler-mumble "") ; Sync before doing more output. - (pre-pack-tn-stats component *standard-output*)) + (when *compile-progress* + (compiler-mumble "") ; Sync before doing more output. + (pre-pack-tn-stats component *standard-output*)) - (when *check-consistency* - (maybe-mumble "check-life ") - (check-life-consistency component)) + (when *check-consistency* + (maybe-mumble "check-life ") + (check-life-consistency component)) - (maybe-mumble "pack ") - (pack component) + (maybe-mumble "pack ") + (pack component) - (when *check-consistency* - (maybe-mumble "check-pack ") - (check-pack-consistency component)) + (when *check-consistency* + (maybe-mumble "check-pack ") + (check-pack-consistency component)) - (when *compiler-trace-output* - (describe-component component *compiler-trace-output*) - (describe-ir2-component component *compiler-trace-output*)) + (when *compiler-trace-output* + (describe-component component *compiler-trace-output*) + (describe-ir2-component component *compiler-trace-output*)) - (maybe-mumble "code ") - (multiple-value-bind (code-length trace-table fixup-notes) - (generate-code component) + (maybe-mumble "code ") + (multiple-value-bind (code-length trace-table fixup-notes) + (generate-code component) #-sb-xc-host - (when *compiler-trace-output* - (format *compiler-trace-output* - "~|~%disassembly of code for ~S~2%" component) - (sb!disassem:disassemble-assem-segment *code-segment* - *compiler-trace-output*)) - - (etypecase *compile-object* - (fasl-output - (maybe-mumble "fasl") - (fasl-dump-component component - *code-segment* - code-length - trace-table - fixup-notes - *compile-object*)) - (core-object - (maybe-mumble "core") - (make-core-component component - *code-segment* - code-length - trace-table - fixup-notes - *compile-object*)) - (null)))))) + (when *compiler-trace-output* + (format *compiler-trace-output* + "~|~%disassembly of code for ~S~2%" component) + (sb!disassem:disassemble-assem-segment *code-segment* + *compiler-trace-output*)) + + (etypecase *compile-object* + (fasl-output + (maybe-mumble "fasl") + (fasl-dump-component component + *code-segment* + code-length + trace-table + fixup-notes + *compile-object*)) + (core-object + (maybe-mumble "core") + (make-core-component component + *code-segment* + code-length + trace-table + fixup-notes + *compile-object*)) + (null)))))) ;; We're done, so don't bother keeping anything around. (setf (component-info component) :dead) @@ -520,9 +520,9 @@ (:toplevel (return)) (:external (unless (every (lambda (ref) - (eq (node-component ref) component)) - (leaf-refs fun)) - (return)))))) + (eq (node-component ref) component)) + (leaf-refs fun)) + (return)))))) (defun compile-component (component) @@ -553,17 +553,17 @@ #| (when (and *loop-analyze* *compiler-trace-output*) (labels ((print-blocks (block) - (format *compiler-trace-output* " ~A~%" block) - (when (block-loop-next block) - (print-blocks (block-loop-next block)))) - (print-loop (loop) - (format *compiler-trace-output* "loop=~A~%" loop) - (print-blocks (loop-blocks loop)) - (dolist (l (loop-inferiors loop)) - (print-loop l)))) - (print-loop (component-outer-loop component)))) + (format *compiler-trace-output* " ~A~%" block) + (when (block-loop-next block) + (print-blocks (block-loop-next block)))) + (print-loop (loop) + (format *compiler-trace-output* "loop=~A~%" loop) + (print-blocks (loop-blocks loop)) + (dolist (l (loop-inferiors loop)) + (print-loop l)))) + (print-loop (component-outer-loop component)))) |# - + ;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more? (maybe-mumble "env ") (physenv-analyze component) @@ -572,11 +572,11 @@ (delete-if-no-entries component) (unless (eq (block-next (component-head component)) - (component-tail component)) + (component-tail component)) (%compile-component component))) (clear-constant-info) - + (values)) ;;;; clearing global data structures @@ -593,14 +593,14 @@ ;;; component boundaries. (defun clear-constant-info () (maphash (lambda (k v) - (declare (ignore k)) - (setf (leaf-info v) nil)) - *constants*) + (declare (ignore k)) + (setf (leaf-info v) nil)) + *constants*) (maphash (lambda (k v) - (declare (ignore k)) - (when (constant-p v) - (setf (leaf-info v) nil))) - *free-vars*) + (declare (ignore k)) + (when (constant-p v) + (setf (leaf-info v) nil))) + *free-vars*) (values)) ;;; Blow away the REFS for all global variables, and let COMPONENT @@ -608,17 +608,17 @@ (defun clear-ir1-info (component) (declare (type component component)) (labels ((blast (x) - (maphash (lambda (k v) - (declare (ignore k)) - (when (leaf-p v) - (setf (leaf-refs v) - (delete-if #'here-p (leaf-refs v))) - (when (basic-var-p v) - (setf (basic-var-sets v) - (delete-if #'here-p (basic-var-sets v)))))) - x)) - (here-p (x) - (eq (node-component x) component))) + (maphash (lambda (k v) + (declare (ignore k)) + (when (leaf-p v) + (setf (leaf-refs v) + (delete-if #'here-p (leaf-refs v))) + (when (basic-var-p v) + (setf (basic-var-sets v) + (delete-if #'here-p (basic-var-sets v)))))) + x)) + (here-p (x) + (eq (node-component x) component))) (blast *free-vars*) (blast *free-funs*) (blast *constants*)) @@ -679,9 +679,9 @@ (format t "entries:~%") (dolist (entry (ir2-component-entries (component-info component))) (format t "~4TL~D: ~S~:[~; [closure]~]~%" - (label-id (entry-info-offset entry)) - (entry-info-name entry) - (entry-info-closure-tn entry))) + (label-id (entry-info-offset entry)) + (entry-info-name entry) + (entry-info-closure-tn entry))) (terpri) (pre-pack-tn-stats component *standard-output*) (terpri) @@ -727,10 +727,10 @@ ;;; The SOURCE-INFO structure provides a handle on all the source ;;; information for an entire compilation. (def!struct (source-info - #-no-ansi-print-object - (:print-object (lambda (s stream) - (print-unreadable-object (s stream :type t)))) - (:copier nil)) + #-no-ansi-print-object + (:print-object (lambda (s stream) + (print-unreadable-object (s stream :type t)))) + (:copier nil)) ;; the UT that compilation started at (start-time (get-universal-time) :type unsigned-byte) ;; the FILE-INFO structure for this compilation @@ -742,24 +742,24 @@ ;;; Given a pathname, return a SOURCE-INFO structure. (defun make-file-source-info (file external-format) (let ((file-info (make-file-info :name (truename file) - :untruename file + :untruename file :external-format external-format - :write-date (file-write-date file)))) + :write-date (file-write-date file)))) (make-source-info :file-info file-info))) -;;; Return a SOURCE-INFO to describe the incremental compilation of FORM. +;;; Return a SOURCE-INFO to describe the incremental compilation of FORM. (defun make-lisp-source-info (form) (make-source-info :start-time (get-universal-time) - :file-info (make-file-info :name :lisp - :forms (vector form) - :positions '#(0)))) + :file-info (make-file-info :name :lisp + :forms (vector form) + :positions '#(0)))) ;;; Return a SOURCE-INFO which will read from STREAM. (defun make-stream-source-info (stream) (let ((file-info (make-file-info :name :stream))) (make-source-info :file-info file-info - :stream stream))) + :stream stream))) ;;; Return a form read from STREAM; or for EOF use the trick, ;;; popularized by Kent Pitman, of returning STREAM itself. If an @@ -770,20 +770,20 @@ (handler-case (read stream nil stream) (reader-error (condition) (error 'input-error-in-compile-file - :condition condition - ;; We don't need to supply :POSITION here because - ;; READER-ERRORs already know their position in the file. - )) + :condition condition + ;; We don't need to supply :POSITION here because + ;; READER-ERRORs already know their position in the file. + )) ;; ANSI, in its wisdom, says that READ should return END-OF-FILE ;; (and that this is not a READER-ERROR) when it encounters end of ;; file in the middle of something it's trying to read. (end-of-file (condition) (error 'input-error-in-compile-file - :condition condition - ;; We need to supply :POSITION here because the END-OF-FILE - ;; condition doesn't carry the position that the user - ;; probably cares about, where the failed READ began. - :position position)))) + :condition condition + ;; We need to supply :POSITION here because the END-OF-FILE + ;; condition doesn't carry the position that the user + ;; probably cares about, where the failed READ began. + :position position)))) ;;; If STREAM is present, return it, otherwise open a stream to the ;;; current file. There must be a current file. @@ -800,11 +800,11 @@ (declare (type source-info info)) (or (source-info-stream info) (let* ((file-info (source-info-file-info info)) - (name (file-info-name file-info)) + (name (file-info-name file-info)) (external-format (file-info-external-format file-info))) - (setf sb!xc:*compile-file-truename* name - sb!xc:*compile-file-pathname* (file-info-untruename file-info) - (source-info-stream info) + (setf sb!xc:*compile-file-truename* name + sb!xc:*compile-file-pathname* (file-info-untruename file-info) + (source-info-stream info) (open name :direction :input :external-format external-format))))) @@ -819,21 +819,21 @@ ;;; Read and compile the source file. (defun sub-sub-compile-file (info) (let* ((file-info (source-info-file-info info)) - (stream (get-source-stream info))) + (stream (get-source-stream info))) (loop (let* ((pos (file-position stream)) - (form (read-for-compile-file stream pos))) + (form (read-for-compile-file stream pos))) (if (eq form stream) ; i.e., if EOF - (return) - (let* ((forms (file-info-forms file-info)) - (current-idx (+ (fill-pointer forms) - (file-info-source-root file-info)))) - (vector-push-extend form forms) - (vector-push-extend pos (file-info-positions file-info)) - (find-source-paths form current-idx) - (process-toplevel-form form - `(original-source-start 0 ,current-idx) - nil))))))) + (return) + (let* ((forms (file-info-forms file-info)) + (current-idx (+ (fill-pointer forms) + (file-info-source-root file-info)))) + (vector-push-extend form forms) + (vector-push-extend pos (file-info-positions file-info)) + (find-source-paths form current-idx) + (process-toplevel-form form + `(original-source-start 0 ,current-idx) + nil))))))) ;;; Return the INDEX'th source form read from INFO and the position ;;; where it was read. @@ -841,7 +841,7 @@ (declare (type index index) (type source-info info)) (let ((file-info (source-info-file-info info))) (values (aref (file-info-forms file-info) index) - (aref (file-info-positions file-info) index)))) + (aref (file-info-positions file-info) index)))) ;;;; processing of top level forms @@ -852,12 +852,12 @@ (defun convert-and-maybe-compile (form path) (declare (list path)) (let* ((*top-level-form-noted* (note-top-level-form form t)) - (*lexenv* (make-lexenv + (*lexenv* (make-lexenv :policy *policy* :handled-conditions *handled-conditions* :disabled-package-locks *disabled-package-locks*)) - (tll (ir1-toplevel form path nil))) - (if (eq *block-compile* t) + (tll (ir1-toplevel form path nil))) + (if (eq *block-compile* t) (push tll *toplevel-lambdas*) (compile-toplevel (list tll) nil)) nil)) @@ -869,10 +869,10 @@ (handler-case (sb!xc:macroexpand-1 form *lexenv*) (error (condition) (compiler-error "(during macroexpansion of ~A)~%~A" - (let ((*print-level* 2) - (*print-length* 2)) - (format nil "~S" form)) - condition)))) + (let ((*print-level* 2) + (*print-length* 2)) + (format nil "~S" form)) + condition)))) ;;; Process a PROGN-like portion of a top level form. FORMS is a list of ;;; the forms, and PATH is the source path of the FORM they came out of. @@ -892,21 +892,21 @@ (let* ((*lexenv* (process-decls decls vars funs)) ;; FIXME: VALUES declaration ;; - ;; Binding *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 *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 of silently screwing up. - (*policy* (lexenv-policy *lexenv*)) - ;; This is probably also a hack - (*handled-conditions* (lexenv-handled-conditions *lexenv*)) - ;; ditto - (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))) + ;; Binding *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 *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 of silently screwing up. + (*policy* (lexenv-policy *lexenv*)) + ;; This is probably also a hack + (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))) (process-toplevel-progn forms path compile-time-too)))) ;;; Parse an EVAL-WHEN situations list, returning three flags, @@ -914,22 +914,22 @@ ;;; the types of situations present in the list. (defun parse-eval-when-situations (situations) (when (or (not (listp situations)) - (set-difference situations - '(:compile-toplevel - compile - :load-toplevel - load - :execute - eval))) + (set-difference situations + '(:compile-toplevel + compile + :load-toplevel + load + :execute + eval))) (compiler-error "bad EVAL-WHEN situation list: ~S" situations)) (let ((deprecated-names (intersection situations '(compile load eval)))) (when deprecated-names (style-warn "using deprecated EVAL-WHEN situation names~{ ~S~}" - deprecated-names))) + deprecated-names))) (values (intersection '(:compile-toplevel compile) - situations) - (intersection '(:load-toplevel load) situations) - (intersection '(:execute eval) situations))) + situations) + (intersection '(:load-toplevel load) situations) + (intersection '(:execute eval) situations))) ;;; utilities for extracting COMPONENTs of FUNCTIONALs @@ -938,38 +938,38 @@ (etypecase f (clambda (list (lambda-component f))) (optional-dispatch (let ((result nil)) - (flet ((maybe-frob (maybe-clambda) + (flet ((maybe-frob (maybe-clambda) (when (and maybe-clambda (promise-ready-p maybe-clambda)) (pushnew (lambda-component (force maybe-clambda)) - result)))) - (map nil #'maybe-frob (optional-dispatch-entry-points f)) - (maybe-frob (optional-dispatch-more-entry f)) - (maybe-frob (optional-dispatch-main-entry f))) + result)))) + (map nil #'maybe-frob (optional-dispatch-entry-points f)) + (maybe-frob (optional-dispatch-more-entry f)) + (maybe-frob (optional-dispatch-main-entry f))) result)))) (defun make-functional-from-toplevel-lambda (definition - &key - name - (path - ;; I'd thought NIL should - ;; work, but it doesn't. - ;; -- WHN 2001-09-20 - (missing-arg))) + &key + name + (path + ;; I'd thought NIL should + ;; work, but it doesn't. + ;; -- WHN 2001-09-20 + (missing-arg))) (let* ((*current-path* path) (component (make-empty-component)) (*current-component* component)) (setf (component-name component) - (debug-name 'initial-component name)) + (debug-name 'initial-component name)) (setf (component-kind component) :initial) (let* ((locall-fun (let ((*allow-instrumenting* t)) - (apply #'ir1-convert-lambdalike + (apply #'ir1-convert-lambdalike definition (list :source-name name)))) (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) - :source-name (or name '.anonymous.) - :debug-name (debug-name 'tl-xep name)))) + :source-name (or name '.anonymous.) + :debug-name (debug-name 'tl-xep name)))) (when name (assert-global-function-definition-type name locall-fun)) (setf (functional-entry-fun fun) locall-fun @@ -987,25 +987,25 @@ ;;; If NAME is provided, then we try to use it as the name of the ;;; function for debugging/diagnostic information. (defun %compile (lambda-expression - *compile-object* - &key - name - (path - ;; This magical idiom seems to be the appropriate - ;; path for compiling standalone LAMBDAs, judging - ;; from the CMU CL code and experiment, so it's a - ;; nice default for things where we don't have a - ;; real source path (as in e.g. inside CL:COMPILE). - '(original-source-start 0 0))) + *compile-object* + &key + name + (path + ;; This magical idiom seems to be the appropriate + ;; path for compiling standalone LAMBDAs, judging + ;; from the CMU CL code and experiment, so it's a + ;; nice default for things where we don't have a + ;; real source path (as in e.g. inside CL:COMPILE). + '(original-source-start 0 0))) (when name (legal-fun-name-or-type-error name)) - (let* ((*lexenv* (make-lexenv + (let* ((*lexenv* (make-lexenv :policy *policy* :handled-conditions *handled-conditions* :disabled-package-locks *disabled-package-locks*)) (fun (make-functional-from-toplevel-lambda lambda-expression - :name name - :path path))) + :name name + :path path))) ;; FIXME: The compile-it code from here on is sort of a ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be @@ -1027,53 +1027,53 @@ (replace-toplevel-xeps component-from-dfo))) (let ((entry-table (etypecase *compile-object* - (fasl-output (fasl-output-entry-table - *compile-object*)) - (core-object (core-object-entry-table - *compile-object*))))) - (multiple-value-bind (result found-p) - (gethash (leaf-info fun) entry-table) - (aver found-p) - (prog1 + (fasl-output (fasl-output-entry-table + *compile-object*)) + (core-object (core-object-entry-table + *compile-object*))))) + (multiple-value-bind (result found-p) + (gethash (leaf-info fun) entry-table) + (aver found-p) + (prog1 result - ;; KLUDGE: This code duplicates some other code in this - ;; file. In the great reorganzation, the flow of program - ;; logic changed from the original CMUCL model, and that - ;; path (as of sbcl-0.7.5 in SUB-COMPILE-FILE) was no - ;; longer followed for CORE-OBJECTS, leading to BUG - ;; 156. This place is transparently not the right one for - ;; this code, but I don't have a clear enough overview of - ;; the compiler to know how to rearrange it all so that - ;; this operation fits in nicely, and it was blocking - ;; reimplementation of (DECLAIM (INLINE FOO)) (MACROLET - ;; ((..)) (DEFUN FOO ...)) - ;; - ;; FIXME: This KLUDGE doesn't solve all the problem in an - ;; ideal way, as (1) definitions typed in at the REPL - ;; without an INLINE declaration will give a NULL - ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal) - ;; and (2) INLINE declarations will yield a - ;; FUNCTION-LAMBDA-EXPRESSION headed by - ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV. -- CSR, - ;; 2002-07-02 - ;; - ;; (2) is probably fairly easy to fix -- it is, after all, - ;; a matter of list manipulation (or possibly of teaching - ;; CL:FUNCTION about SB-C:LAMBDA-WITH-LEXENV). (1) is - ;; significantly harder, as the association between - ;; function object and source is a tricky one. - ;; - ;; FUNCTION-LAMBDA-EXPRESSION "works" (i.e. returns a - ;; non-NULL list) when the function in question has been - ;; compiled by (COMPILE '(LAMBDA ...)); it does not - ;; work when it has been compiled as part of the top-level - ;; EVAL strategy of compiling everything inside (LAMBDA () - ;; ...). -- CSR, 2002-11-02 - (when (core-object-p *compile-object*) - (fix-core-source-info *source-info* *compile-object* result)) - - (mapc #'clear-ir1-info components-from-dfo) - (clear-stuff))))))) + ;; KLUDGE: This code duplicates some other code in this + ;; file. In the great reorganzation, the flow of program + ;; logic changed from the original CMUCL model, and that + ;; path (as of sbcl-0.7.5 in SUB-COMPILE-FILE) was no + ;; longer followed for CORE-OBJECTS, leading to BUG + ;; 156. This place is transparently not the right one for + ;; this code, but I don't have a clear enough overview of + ;; the compiler to know how to rearrange it all so that + ;; this operation fits in nicely, and it was blocking + ;; reimplementation of (DECLAIM (INLINE FOO)) (MACROLET + ;; ((..)) (DEFUN FOO ...)) + ;; + ;; FIXME: This KLUDGE doesn't solve all the problem in an + ;; ideal way, as (1) definitions typed in at the REPL + ;; without an INLINE declaration will give a NULL + ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal) + ;; and (2) INLINE declarations will yield a + ;; FUNCTION-LAMBDA-EXPRESSION headed by + ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV. -- CSR, + ;; 2002-07-02 + ;; + ;; (2) is probably fairly easy to fix -- it is, after all, + ;; a matter of list manipulation (or possibly of teaching + ;; CL:FUNCTION about SB-C:LAMBDA-WITH-LEXENV). (1) is + ;; significantly harder, as the association between + ;; function object and source is a tricky one. + ;; + ;; FUNCTION-LAMBDA-EXPRESSION "works" (i.e. returns a + ;; non-NULL list) when the function in question has been + ;; compiled by (COMPILE '(LAMBDA ...)); it does not + ;; work when it has been compiled as part of the top-level + ;; EVAL strategy of compiling everything inside (LAMBDA () + ;; ...). -- CSR, 2002-11-02 + (when (core-object-p *compile-object*) + (fix-core-source-info *source-info* *compile-object* result)) + + (mapc #'clear-ir1-info components-from-dfo) + (clear-stuff))))))) (defun process-toplevel-cold-fset (name lambda-expression path) (unless (producing-fasl-file) @@ -1083,7 +1083,7 @@ (%compile lambda-expression *compile-object* :name name - :path path) + :path path) *compile-object*) (values)) @@ -1094,7 +1094,7 @@ (*print-level* 2) (*print-pretty* nil)) (with-compiler-io-syntax - (compiler-mumble "~&; ~:[compiling~;converting~] ~S" + (compiler-mumble "~&; ~:[compiling~;converting~] ~S" *block-compile* form))) form) ((and finalp @@ -1119,14 +1119,14 @@ (defun process-toplevel-form (form path compile-time-too) (declare (list path)) - (catch 'process-toplevel-form-error-abort + (catch 'process-toplevel-form-error-abort (let* ((path (or (gethash form *source-paths*) (cons form path))) - (*compiler-error-bailout* - (lambda (&optional condition) - (convert-and-maybe-compile - (make-compiler-error-form condition form) - path) - (throw 'process-toplevel-form-error-abort nil)))) + (*compiler-error-bailout* + (lambda (&optional condition) + (convert-and-maybe-compile + (make-compiler-error-form condition form) + path) + (throw 'process-toplevel-form-error-abort nil)))) (flet ((default-processor (form) (let ((*top-level-form-noted* (note-top-level-form form))) @@ -1198,8 +1198,8 @@ ;; (There are no xc EVAL-WHEN issues in the ATOM case until ;; (1) SBCL gets smart enough to handle global ;; DEFINE-SYMBOL-MACRO or SYMBOL-MACROLET and (2) SBCL - ;; implementors start using symbol macros in a way which - ;; interacts with SB-XC/CL distinction.) + ;; implementors start using symbol macros in a way which + ;; interacts with SB-XC/CL distinction.) (convert-and-maybe-compile form path) #-sb-xc-host (default-processor form) @@ -1241,7 +1241,7 @@ magic (lambda (&key funs prepend) (declare (ignore funs)) - (aver (null prepend)) + (aver (null prepend)) (process-toplevel-locally body path compile-time-too)) @@ -1250,7 +1250,7 @@ (funcall-in-symbol-macrolet-lexenv magic (lambda (&key vars prepend) - (aver (null prepend)) + (aver (null prepend)) (process-toplevel-locally body path compile-time-too @@ -1281,8 +1281,8 @@ (fasl-dump-load-time-value-lambda lambda *compile-object*) (let ((type (leaf-type lambda))) (if (fun-type-p type) - (single-value-type (fun-type-returns type)) - *wild-type*))))) + (single-value-type (fun-type-returns type)) + *wild-type*))))) ;;; Compile the FORMS and arrange for them to be called (for effect, ;;; not value) at load time. @@ -1295,7 +1295,7 @@ (defun compile-load-time-stuff (form for-value) (with-ir1-namespace (let* ((*lexenv* (make-null-lexenv)) - (lambda (ir1-toplevel form *current-path* for-value))) + (lambda (ir1-toplevel form *current-path* for-value))) (compile-toplevel (list lambda) t) lambda))) @@ -1307,7 +1307,7 @@ (defun compile-load-time-value-lambda (lambdas) (aver (null (cdr lambdas))) (let* ((lambda (car lambdas)) - (component (lambda-component lambda))) + (component (lambda-component lambda))) (when (eql (component-kind component) :toplevel) (setf (component-name component) (leaf-debug-name lambda)) (compile-component component) @@ -1341,33 +1341,33 @@ (declare (list lambdas)) (let ((len (length lambdas))) (flet ((loser (start) - (or (position-if (lambda (x) - (not (eq (component-kind - (node-component (lambda-bind x))) - :toplevel))) - lambdas - ;; this used to read ":start start", but - ;; start can be greater than len, which - ;; is an error according to ANSI - CSR, - ;; 2002-04-25 - :start (min start len)) - len))) + (or (position-if (lambda (x) + (not (eq (component-kind + (node-component (lambda-bind x))) + :toplevel))) + lambdas + ;; this used to read ":start start", but + ;; start can be greater than len, which + ;; is an error according to ANSI - CSR, + ;; 2002-04-25 + :start (min start len)) + len))) (do* ((start 0 (1+ loser)) - (loser (loser start) (loser start))) - ((>= start len)) - (sub-compile-toplevel-lambdas (subseq lambdas start loser)) - (unless (= loser len) - (object-call-toplevel-lambda (elt lambdas loser)))))) + (loser (loser start) (loser start))) + ((>= start len)) + (sub-compile-toplevel-lambdas (subseq lambdas start loser)) + (unless (= loser len) + (object-call-toplevel-lambda (elt lambdas loser)))))) (values)) ;;; Compile LAMBDAS (a list of CLAMBDAs for top level forms) into the -;;; object file. +;;; object file. ;;; ;;; LOAD-TIME-VALUE-P seems to control whether it's MAKE-LOAD-FORM and ;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201 (defun compile-toplevel (lambdas load-time-value-p) (declare (list lambdas)) - + (maybe-mumble "locall ") (locall-analyze-clambdas-until-done lambdas) @@ -1376,23 +1376,23 @@ (find-initial-dfo lambdas) (let ((*all-components* (append components top-components))) (when *check-consistency* - (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) + (maybe-mumble "[check]~%") + (check-ir1-consistency *all-components*)) (dolist (component (append hairy-top top-components)) - (pre-physenv-analyze-toplevel component)) + (pre-physenv-analyze-toplevel component)) (dolist (component components) - (compile-component component) - (replace-toplevel-xeps component)) - + (compile-component component) + (replace-toplevel-xeps component)) + (when *check-consistency* - (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) - + (maybe-mumble "[check]~%") + (check-ir1-consistency *all-components*)) + (if load-time-value-p - (compile-load-time-value-lambda lambdas) - (compile-toplevel-lambdas lambdas)) + (compile-load-time-value-lambda lambdas) + (compile-toplevel-lambdas lambdas)) (mapc #'clear-ir1-info components) (clear-stuff))) @@ -1412,42 +1412,42 @@ (defun handle-condition-p (condition) (let ((lexenv - (etypecase *compiler-error-context* - (node - (node-lexenv *compiler-error-context*)) - (compiler-error-context - (let ((lexenv (compiler-error-context-lexenv - *compiler-error-context*))) - (aver lexenv) - lexenv)) - (null *lexenv*)))) + (etypecase *compiler-error-context* + (node + (node-lexenv *compiler-error-context*)) + (compiler-error-context + (let ((lexenv (compiler-error-context-lexenv + *compiler-error-context*))) + (aver lexenv) + lexenv)) + (null *lexenv*)))) (let ((muffles (lexenv-handled-conditions lexenv))) (if (null muffles) ; common case - nil - (dolist (muffle muffles nil) - (destructuring-bind (typespec . restart-name) muffle - (when (and (typep condition typespec) - (find-restart restart-name condition)) - (return t)))))))) + nil + (dolist (muffle muffles nil) + (destructuring-bind (typespec . restart-name) muffle + (when (and (typep condition typespec) + (find-restart restart-name condition)) + (return t)))))))) (defun handle-condition-handler (condition) (let ((lexenv - (etypecase *compiler-error-context* - (node - (node-lexenv *compiler-error-context*)) - (compiler-error-context - (let ((lexenv (compiler-error-context-lexenv - *compiler-error-context*))) - (aver lexenv) - lexenv)) - (null *lexenv*)))) + (etypecase *compiler-error-context* + (node + (node-lexenv *compiler-error-context*)) + (compiler-error-context + (let ((lexenv (compiler-error-context-lexenv + *compiler-error-context*))) + (aver lexenv) + lexenv)) + (null *lexenv*)))) (let ((muffles (lexenv-handled-conditions lexenv))) (aver muffles) (dolist (muffle muffles (bug "fell through")) - (destructuring-bind (typespec . restart-name) muffle - (when (typep condition typespec) - (awhen (find-restart restart-name condition) - (invoke-restart it)))))))) + (destructuring-bind (typespec . restart-name) muffle + (when (typep condition typespec) + (awhen (find-restart restart-name condition) + (invoke-restart it)))))))) ;;; Read all forms from INFO and compile them, with output to OBJECT. ;;; Return (VALUES NIL WARNINGS-P FAILURE-P). @@ -1458,8 +1458,8 @@ (sb!xc:*compile-file-pathname* nil) ; really bound in (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE (*policy* *policy*) - (*handled-conditions* *handled-conditions*) - (*disabled-package-locks* *disabled-package-locks*) + (*handled-conditions* *handled-conditions*) + (*disabled-package-locks* *disabled-package-locks*) (*lexenv* (make-null-lexenv)) (*block-compile* *block-compile-arg*) (*source-info* info) @@ -1485,20 +1485,20 @@ (*info-environment* *info-environment*) (*gensym-counter* 0)) (handler-case - (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) - (with-compilation-values - (sb!xc:with-compilation-unit () - (clear-stuff) - - (sub-sub-compile-file info) - - (finish-block-compilation) - (let ((object *compile-object*)) - (etypecase object - (fasl-output (fasl-dump-source-info info object)) - (core-object (fix-core-source-info info object)) - (null))) - nil))) + (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) + (with-compilation-values + (sb!xc:with-compilation-unit () + (clear-stuff) + + (sub-sub-compile-file info) + + (finish-block-compilation) + (let ((object *compile-object*)) + (etypecase object + (fasl-output (fasl-dump-source-info info object)) + (core-object (fix-core-source-info info object)) + (null))) + nil))) ;; Some errors are sufficiently bewildering that we just fail ;; immediately, without trying to recover and compile more of ;; the input file. @@ -1513,19 +1513,19 @@ ;;; Return a pathname for the named file. The file must exist. (defun verify-source-file (pathname-designator) (let* ((pathname (pathname pathname-designator)) - (default-host (make-pathname :host (pathname-host pathname)))) + (default-host (make-pathname :host (pathname-host pathname)))) (flet ((try-with-type (path type error-p) - (let ((new (merge-pathnames - path (make-pathname :type type - :defaults default-host)))) - (if (probe-file new) - new - (and error-p (truename new)))))) + (let ((new (merge-pathnames + path (make-pathname :type type + :defaults default-host)))) + (if (probe-file new) + new + (and error-p (truename new)))))) (cond ((typep pathname 'logical-pathname) - (try-with-type pathname "LISP" t)) - ((probe-file pathname) pathname) - ((try-with-type pathname "lisp" nil)) - ((try-with-type pathname "lisp" t)))))) + (try-with-type pathname "LISP" t)) + ((probe-file pathname) pathname) + ((try-with-type pathname "lisp" nil)) + ((try-with-type pathname "lisp" t)))))) (defun elapsed-time-to-string (tsec) (multiple-value-bind (tmin sec) (truncate tsec 60) @@ -1537,22 +1537,22 @@ (declare (type source-info source-info)) (let ((file-info (source-info-file-info source-info))) (compiler-mumble "~&; compiling file ~S (written ~A):~%" - (namestring (file-info-name file-info)) - (sb!int:format-universal-time nil - (file-info-write-date - file-info) - :style :government - :print-weekday nil - :print-timezone nil))) + (namestring (file-info-name file-info)) + (sb!int:format-universal-time nil + (file-info-write-date + file-info) + :style :government + :print-weekday nil + :print-timezone nil))) (values)) (defun print-compile-end-note (source-info won) (declare (type source-info source-info)) (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&" - won - (elapsed-time-to-string - (- (get-universal-time) - (source-info-start-time source-info)))) + won + (elapsed-time-to-string + (- (get-universal-time) + (source-info-start-time source-info)))) (values)) ;;; Open some files and call SUB-COMPILE-FILE. If something unwinds @@ -1572,20 +1572,20 @@ (external-format :default) ;; extensions - (trace-file nil) + (trace-file nil) ((:block-compile *block-compile-arg*) nil)) #!+sb-doc "Compile INPUT-FILE, producing a corresponding fasl file and returning its filename. :PRINT - If true, a message per non-macroexpanded top level form is printed + If true, a message per non-macroexpanded top level form is printed to *STANDARD-OUTPUT*. Top level forms that whose subforms are processed as top level forms (eg. EVAL-WHEN, MACROLET, PROGN) receive no such message, but their subforms do. - As an extension to ANSI, if :PRINT is :top-level-forms, a message - per top level form after macroexpansion is printed to *STANDARD-OUTPUT*. + As an extension to ANSI, if :PRINT is :top-level-forms, a message + per top level form after macroexpansion is printed to *STANDARD-OUTPUT*. For example, compiling an IN-PACKAGE form will result in a message about a top level SETQ in addition to the message about the IN-PACKAGE form' itself. @@ -1616,65 +1616,65 @@ SPEED and COMPILATION-SPEED optimization values, and the :BLOCK-COMPILE argument will probably become deprecated." |# (let* ((fasl-output nil) - (output-file-name nil) - (compile-won nil) - (warnings-p nil) - (failure-p t) ; T in case error keeps this from being set later - (input-pathname (verify-source-file input-file)) - (source-info (make-file-source-info input-pathname external-format)) - (*compiler-trace-output* nil)) ; might be modified below + (output-file-name nil) + (compile-won nil) + (warnings-p nil) + (failure-p t) ; T in case error keeps this from being set later + (input-pathname (verify-source-file input-file)) + (source-info (make-file-source-info input-pathname external-format)) + (*compiler-trace-output* nil)) ; might be modified below (unwind-protect - (progn - (when output-file - (setq output-file-name - (sb!xc:compile-file-pathname input-file - :output-file output-file)) - (setq fasl-output - (open-fasl-output output-file-name - (namestring input-pathname)))) - (when trace-file - (let* ((default-trace-file-pathname - (make-pathname :type "trace" :defaults input-pathname)) - (trace-file-pathname - (if (eql trace-file t) - default-trace-file-pathname - (merge-pathnames trace-file - default-trace-file-pathname)))) - (setf *compiler-trace-output* - (open trace-file-pathname - :if-exists :supersede - :direction :output)))) - - (when sb!xc:*compile-verbose* - (print-compile-start-note source-info)) - (let ((*compile-object* fasl-output) - dummy) - (multiple-value-setq (dummy warnings-p failure-p) - (sub-compile-file source-info))) - (setq compile-won t)) + (progn + (when output-file + (setq output-file-name + (sb!xc:compile-file-pathname input-file + :output-file output-file)) + (setq fasl-output + (open-fasl-output output-file-name + (namestring input-pathname)))) + (when trace-file + (let* ((default-trace-file-pathname + (make-pathname :type "trace" :defaults input-pathname)) + (trace-file-pathname + (if (eql trace-file t) + default-trace-file-pathname + (merge-pathnames trace-file + default-trace-file-pathname)))) + (setf *compiler-trace-output* + (open trace-file-pathname + :if-exists :supersede + :direction :output)))) + + (when sb!xc:*compile-verbose* + (print-compile-start-note source-info)) + (let ((*compile-object* fasl-output) + dummy) + (multiple-value-setq (dummy warnings-p failure-p) + (sub-compile-file source-info))) + (setq compile-won t)) (close-source-info source-info) (when fasl-output - (close-fasl-output fasl-output (not compile-won)) - (setq output-file-name - (pathname (fasl-output-stream fasl-output))) - (when (and compile-won sb!xc:*compile-verbose*) - (compiler-mumble "~2&; ~A written~%" (namestring output-file-name)))) + (close-fasl-output fasl-output (not compile-won)) + (setq output-file-name + (pathname (fasl-output-stream fasl-output))) + (when (and compile-won sb!xc:*compile-verbose*) + (compiler-mumble "~2&; ~A written~%" (namestring output-file-name)))) (when sb!xc:*compile-verbose* - (print-compile-end-note source-info compile-won)) + (print-compile-end-note source-info compile-won)) (when *compiler-trace-output* - (close *compiler-trace-output*))) + (close *compiler-trace-output*))) (values (if output-file - ;; Hack around filesystem race condition... - (or (probe-file output-file-name) output-file-name) - nil) - warnings-p - failure-p))) + ;; Hack around filesystem race condition... + (or (probe-file output-file-name) output-file-name) + nil) + warnings-p + failure-p))) ;;; a helper function for COMPILE-FILE-PATHNAME: the default for ;;; the OUTPUT-FILE argument @@ -1686,9 +1686,9 @@ SPEED and COMPILATION-SPEED optimization values, and the ;;; compiled files. (defun cfp-output-file-default (input-file) (let* ((defaults (merge-pathnames input-file *default-pathname-defaults*)) - (retyped (make-pathname :type *fasl-file-type* :defaults defaults))) + (retyped (make-pathname :type *fasl-file-type* :defaults defaults))) retyped)) - + ;;; KLUDGE: Part of the ANSI spec for this seems contradictory: ;;; If INPUT-FILE is a logical pathname and OUTPUT-FILE is unsupplied, ;;; the result is a logical pathname. If INPUT-FILE is a logical @@ -1699,10 +1699,10 @@ SPEED and COMPILATION-SPEED optimization values, and the ;;; physical pathname. Patches to make it more correct are welcome. ;;; -- WHN 2000-12-09 (defun sb!xc:compile-file-pathname (input-file - &key - (output-file (cfp-output-file-default - input-file)) - &allow-other-keys) + &key + (output-file (cfp-output-file-default + input-file)) + &allow-other-keys) #!+sb-doc "Return a pathname describing what file COMPILE-FILE would write to given these arguments." @@ -1762,62 +1762,62 @@ SPEED and COMPILATION-SPEED optimization values, and the (defun emit-make-load-form (constant) (aver (fasl-output-p *compile-object*)) (unless (or (fasl-constant-already-dumped-p constant *compile-object*) - ;; KLUDGE: This special hack is because I was too lazy - ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM - ;; function of LAYOUT returns nontrivial forms when - ;; building the cross-compiler but :IGNORE-IT when - ;; cross-compiling or running under the target Lisp. -- - ;; WHN 19990914 - #+sb-xc-host (typep constant 'layout)) + ;; KLUDGE: This special hack is because I was too lazy + ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM + ;; function of LAYOUT returns nontrivial forms when + ;; building the cross-compiler but :IGNORE-IT when + ;; cross-compiling or running under the target Lisp. -- + ;; WHN 19990914 + #+sb-xc-host (typep constant 'layout)) (let ((circular-ref (assoc constant *constants-being-created* :test #'eq))) (when circular-ref - (when (find constant *constants-created-since-last-init* :test #'eq) - (throw constant t)) - (throw 'pending-init circular-ref))) + (when (find constant *constants-created-since-last-init* :test #'eq) + (throw constant t)) + (throw 'pending-init circular-ref))) (multiple-value-bind (creation-form init-form) - (handler-case + (handler-case (sb!xc:make-load-form constant (make-null-lexenv)) - (error (condition) - (compiler-error condition))) + (error (condition) + (compiler-error condition))) (case creation-form - (:sb-just-dump-it-normally - (fasl-validate-structure constant *compile-object*) - t) - (:ignore-it - nil) - (t - (when (fasl-constant-already-dumped-p constant *compile-object*) - (return-from emit-make-load-form nil)) - (let* ((name (write-to-string constant :level 1 :length 2)) - (info (if init-form - (list constant name init-form) - (list constant)))) - (let ((*constants-being-created* - (cons info *constants-being-created*)) - (*constants-created-since-last-init* - (cons constant *constants-created-since-last-init*))) - (when - (catch constant - (fasl-note-handle-for-constant - constant - (compile-load-time-value - creation-form) - *compile-object*) - nil) - (compiler-error "circular references in creation form for ~S" - constant))) - (when (cdr info) - (let* ((*constants-created-since-last-init* nil) - (circular-ref - (catch 'pending-init - (loop for (name form) on (cdr info) by #'cddr - collect name into names - collect form into forms - finally (compile-make-load-form-init-forms forms)) - nil))) - (when circular-ref - (setf (cdr circular-ref) - (append (cdr circular-ref) (cdr info)))))))))))) + (:sb-just-dump-it-normally + (fasl-validate-structure constant *compile-object*) + t) + (:ignore-it + nil) + (t + (when (fasl-constant-already-dumped-p constant *compile-object*) + (return-from emit-make-load-form nil)) + (let* ((name (write-to-string constant :level 1 :length 2)) + (info (if init-form + (list constant name init-form) + (list constant)))) + (let ((*constants-being-created* + (cons info *constants-being-created*)) + (*constants-created-since-last-init* + (cons constant *constants-created-since-last-init*))) + (when + (catch constant + (fasl-note-handle-for-constant + constant + (compile-load-time-value + creation-form) + *compile-object*) + nil) + (compiler-error "circular references in creation form for ~S" + constant))) + (when (cdr info) + (let* ((*constants-created-since-last-init* nil) + (circular-ref + (catch 'pending-init + (loop for (name form) on (cdr info) by #'cddr + collect name into names + collect form into forms + finally (compile-make-load-form-init-forms forms)) + nil))) + (when circular-ref + (setf (cdr circular-ref) + (append (cdr circular-ref) (cdr info)))))))))))) ;;;; Host compile time definitions diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index aa732a6..3d5dfef 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -42,47 +42,47 @@ (aver (typep size 'unsigned-byte)))) (let ((res (if (eq kind :non-packed) - (make-sb :name name :kind kind) - (make-finite-sb :name name :kind kind :size size)))) + (make-sb :name name :kind kind) + (make-finite-sb :name name :kind kind :size size)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE") - (setf (gethash ',name *backend-meta-sb-names*) - ',res)) + (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE") + (setf (gethash ',name *backend-meta-sb-names*) + ',res)) (/show0 "about to SETF GETHASH SB-NAMES in DEFINE-STORAGE-BASE") ,(if (eq kind :non-packed) - `(setf (gethash ',name *backend-sb-names*) - (copy-sb ',res)) - `(let ((res (copy-finite-sb ',res))) - (/show0 "not :NON-PACKED, i.e. hairy case") - (setf (finite-sb-always-live res) - (make-array ',size - :initial-element - #-(or sb-xc sb-xc-host) #* - ;; The cross-compiler isn't very good - ;; at dumping specialized arrays; we - ;; work around that by postponing - ;; generation of the specialized - ;; array 'til runtime. - #+(or sb-xc sb-xc-host) - (make-array 0 :element-type 'bit))) - (/show0 "doing second SETF") - (setf (finite-sb-conflicts res) - (make-array ',size :initial-element '#())) - (/show0 "doing third SETF") - (setf (finite-sb-live-tns res) - (make-array ',size :initial-element nil)) - (/show0 "doing fourth SETF") - (setf (finite-sb-always-live-count res) - (make-array ',size :initial-element 0)) - (/show0 "doing fifth and final SETF") - (setf (gethash ',name *backend-sb-names*) - res))) + `(setf (gethash ',name *backend-sb-names*) + (copy-sb ',res)) + `(let ((res (copy-finite-sb ',res))) + (/show0 "not :NON-PACKED, i.e. hairy case") + (setf (finite-sb-always-live res) + (make-array ',size + :initial-element + #-(or sb-xc sb-xc-host) #* + ;; The cross-compiler isn't very good + ;; at dumping specialized arrays; we + ;; work around that by postponing + ;; generation of the specialized + ;; array 'til runtime. + #+(or sb-xc sb-xc-host) + (make-array 0 :element-type 'bit))) + (/show0 "doing second SETF") + (setf (finite-sb-conflicts res) + (make-array ',size :initial-element '#())) + (/show0 "doing third SETF") + (setf (finite-sb-live-tns res) + (make-array ',size :initial-element nil)) + (/show0 "doing fourth SETF") + (setf (finite-sb-always-live-count res) + (make-array ',size :initial-element 0)) + (/show0 "doing fifth and final SETF") + (setf (gethash ',name *backend-sb-names*) + res))) (/show0 "about to put SB onto/into SB-LIST") (setf *backend-sb-list* - (cons (sb-or-lose ',name) - (remove ',name *backend-sb-list* :key #'sb-name))) + (cons (sb-or-lose ',name) + (remove ',name *backend-sb-list* :key #'sb-name))) (/show0 "finished with DEFINE-STORAGE-BASE expansion") ',name))) @@ -122,8 +122,8 @@ ;;; A list of the names of all the constant SCs that can be loaded into this ;;; SC by a move function. (defmacro define-storage-class (name number sb-name &key (element-size '1) - (alignment '1) locations reserve-locations - save-p alternate-scs constant-scs) + (alignment '1) locations reserve-locations + save-p alternate-scs constant-scs) (declare (type symbol name)) (declare (type sc-number number)) (declare (type symbol sb-name)) @@ -134,59 +134,59 @@ (let ((sb (meta-sb-or-lose sb-name))) (if (eq (sb-kind sb) :finite) - (let ((size (sb-size sb)) - (element-size (eval element-size))) - (declare (type unsigned-byte element-size)) - (dolist (el locations) - (declare (type unsigned-byte el)) - (unless (<= 1 (+ el element-size) size) - (error "SC element ~W out of bounds for ~S" el sb)))) - (when locations - (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb)))) + (let ((size (sb-size sb)) + (element-size (eval element-size))) + (declare (type unsigned-byte element-size)) + (dolist (el locations) + (declare (type unsigned-byte el)) + (unless (<= 1 (+ el element-size) size) + (error "SC element ~W out of bounds for ~S" el sb)))) + (when locations + (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb)))) (unless (subsetp reserve-locations locations) (error "RESERVE-LOCATIONS not a subset of LOCATIONS.")) (when (and (or alternate-scs constant-scs) - (eq (sb-kind sb) :non-packed)) + (eq (sb-kind sb) :non-packed)) (error "It's meaningless to specify alternate or constant SCs in a ~S SB." (sb-kind sb)))) (let ((nstack-p - (if (or (eq sb-name 'non-descriptor-stack) - (find 'non-descriptor-stack - (mapcar #'meta-sc-or-lose alternate-scs) - :key (lambda (x) - (sb-name (sc-sb x))))) - t nil))) + (if (or (eq sb-name 'non-descriptor-stack) + (find 'non-descriptor-stack + (mapcar #'meta-sc-or-lose alternate-scs) + :key (lambda (x) + (sb-name (sc-sb x))))) + t nil))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((res (make-sc :name ',name :number ',number - :sb (meta-sb-or-lose ',sb-name) - :element-size ,element-size - :alignment ,alignment - :locations ',locations - :reserve-locations ',reserve-locations - :save-p ',save-p - :number-stack-p ,nstack-p - :alternate-scs (mapcar #'meta-sc-or-lose - ',alternate-scs) - :constant-scs (mapcar #'meta-sc-or-lose - ',constant-scs)))) - (setf (gethash ',name *backend-meta-sc-names*) res) - (setf (svref *backend-meta-sc-numbers* ',number) res) - (setf (svref (sc-load-costs res) ',number) 0))) + (let ((res (make-sc :name ',name :number ',number + :sb (meta-sb-or-lose ',sb-name) + :element-size ,element-size + :alignment ,alignment + :locations ',locations + :reserve-locations ',reserve-locations + :save-p ',save-p + :number-stack-p ,nstack-p + :alternate-scs (mapcar #'meta-sc-or-lose + ',alternate-scs) + :constant-scs (mapcar #'meta-sc-or-lose + ',constant-scs)))) + (setf (gethash ',name *backend-meta-sc-names*) res) + (setf (svref *backend-meta-sc-numbers* ',number) res) + (setf (svref (sc-load-costs res) ',number) 0))) (let ((old (svref *backend-sc-numbers* ',number))) - (when (and old (not (eq (sc-name old) ',name))) - (warn "redefining SC number ~W from ~S to ~S" ',number - (sc-name old) ',name))) + (when (and old (not (eq (sc-name old) ',name))) + (warn "redefining SC number ~W from ~S to ~S" ',number + (sc-name old) ',name))) (setf (svref *backend-sc-numbers* ',number) - (meta-sc-or-lose ',name)) + (meta-sc-or-lose ',name)) (setf (gethash ',name *backend-sc-names*) - (meta-sc-or-lose ',name)) + (meta-sc-or-lose ',name)) (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name)) ',name))) @@ -196,13 +196,13 @@ ;;; etc.), bind TO-SC and FROM-SC to all the combinations. (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body) `(do ((froms ,scs (cddr froms)) - (tos (cdr ,scs) (cddr tos))) + (tos (cdr ,scs) (cddr tos))) ((null froms)) (dolist (from (car froms)) (let ((,from-sc-var (meta-sc-or-lose from))) - (dolist (to (car tos)) - (let ((,to-sc-var (meta-sc-or-lose to))) - ,@body)))))) + (dolist (to (car tos)) + (let ((,to-sc-var (meta-sc-or-lose to))) + ,@body)))))) ;;; Define the function NAME and note it as the function used for ;;; moving operands from the From-SCs to the To-SCs. Cost is the cost @@ -218,14 +218,14 @@ `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (do-sc-pairs (from-sc to-sc ',scs) - (unless (eq from-sc to-sc) - (let ((num (sc-number from-sc))) - (setf (svref (sc-move-funs to-sc) num) ',name) - (setf (svref (sc-load-costs to-sc) num) ',cost))))) + (unless (eq from-sc to-sc) + (let ((num (sc-number from-sc))) + (setf (svref (sc-move-funs to-sc) num) ',name) + (setf (svref (sc-load-costs to-sc) num) ',cost))))) (defun ,name ,lambda-list (sb!assem:assemble (*code-segment* ,(first lambda-list)) - ,@body)))) + ,@body)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *sc-vop-slots* @@ -244,34 +244,34 @@ (when (or (oddp (length scs)) (null scs)) (error "malformed SCs spec: ~S" scs)) (let ((accessor (or (cdr (assoc kind *sc-vop-slots*)) - (error "unknown kind ~S" kind)))) + (error "unknown kind ~S" kind)))) `(progn ,@(when (eq kind :move) - `((eval-when (:compile-toplevel :load-toplevel :execute) - (do-sc-pairs (from-sc to-sc ',scs) - (compute-move-costs from-sc to-sc - ,(vop-parse-cost - (vop-parse-or-lose name))))))) + `((eval-when (:compile-toplevel :load-toplevel :execute) + (do-sc-pairs (from-sc to-sc ',scs) + (compute-move-costs from-sc to-sc + ,(vop-parse-cost + (vop-parse-or-lose name))))))) (let ((vop (template-or-lose ',name))) - (do-sc-pairs (from-sc to-sc ',scs) - (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc))) - (let ((vec (,accessor dest-sc))) - (let ((scn (sc-number from-sc))) - (setf (svref vec scn) - (adjoin-template vop (svref vec scn)))) - (dolist (sc (append (sc-alternate-scs from-sc) - (sc-constant-scs from-sc))) - (let ((scn (sc-number sc))) - (setf (svref vec scn) - (adjoin-template vop (svref vec scn)))))))))))) + (do-sc-pairs (from-sc to-sc ',scs) + (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc))) + (let ((vec (,accessor dest-sc))) + (let ((scn (sc-number from-sc))) + (setf (svref vec scn) + (adjoin-template vop (svref vec scn)))) + (dolist (sc (append (sc-alternate-scs from-sc) + (sc-constant-scs from-sc))) + (let ((scn (sc-number sc))) + (setf (svref vec scn) + (adjoin-template vop (svref vec scn)))))))))))) ;;;; primitive type definition (defun meta-primitive-type-or-lose (name) (the primitive-type (or (gethash name *backend-meta-primitive-type-names*) - (error "~S is not a defined primitive type." name)))) + (error "~S is not a defined primitive type." name)))) ;;; Define a primitive type NAME. Each SCS entry specifies a storage ;;; class that values of this type may be allocated in. TYPE is the @@ -283,33 +283,33 @@ (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..") (/primitive-print ,(symbol-name name)) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - (setf (gethash ',name *backend-meta-primitive-type-names*) - (make-primitive-type :name ',name - :scs ',scns - :specifier ',type))) + (setf (gethash ',name *backend-meta-primitive-type-names*) + (make-primitive-type :name ',name + :scs ',scns + :specifier ',type))) ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))) - `(progn - ;; If the PRIMITIVE-TYPE structure already exists, we - ;; destructively modify it so that existing references in - ;; templates won't be invalidated. FIXME: This should no - ;; longer be an issue in SBCL, since we don't try to do - ;; serious surgery on ourselves. Probably this should - ;; just become an assertion that N-OLD is NIL, so that we - ;; don't have to try to maintain the correctness of the - ;; never-ordinarily-used clause. - (/show0 "in !DEF-PRIMITIVE-TYPE, about to COND") - (cond (,n-old - (/show0 "in ,N-OLD clause of COND") - (setf (primitive-type-scs ,n-old) ',scns) - (setf (primitive-type-specifier ,n-old) ',type)) - (t - (/show0 "in T clause of COND") - (setf (gethash ',name *backend-primitive-type-names*) - (make-primitive-type :name ',name - :scs ',scns - :specifier ',type)))) - (/show0 "done with !DEF-PRIMITIVE-TYPE") - ',name))))) + `(progn + ;; If the PRIMITIVE-TYPE structure already exists, we + ;; destructively modify it so that existing references in + ;; templates won't be invalidated. FIXME: This should no + ;; longer be an issue in SBCL, since we don't try to do + ;; serious surgery on ourselves. Probably this should + ;; just become an assertion that N-OLD is NIL, so that we + ;; don't have to try to maintain the correctness of the + ;; never-ordinarily-used clause. + (/show0 "in !DEF-PRIMITIVE-TYPE, about to COND") + (cond (,n-old + (/show0 "in ,N-OLD clause of COND") + (setf (primitive-type-scs ,n-old) ',scns) + (setf (primitive-type-specifier ,n-old) ',type)) + (t + (/show0 "in T clause of COND") + (setf (gethash ',name *backend-primitive-type-names*) + (make-primitive-type :name ',name + :scs ',scns + :specifier ',type)))) + (/show0 "done with !DEF-PRIMITIVE-TYPE") + ',name))))) ;;; Define NAME to be an alias for RESULT in VOP operand type restrictions. (defmacro !def-primitive-type-alias (name result) @@ -331,19 +331,19 @@ ;;; result, checking that the value is of this type in the process. (defmacro primitive-type-vop (vop kinds &rest types) (let ((n-vop (gensym)) - (n-type (gensym))) + (n-type (gensym))) `(let ((,n-vop (template-or-lose ',vop))) ,@(mapcar - (lambda (type) - `(let ((,n-type (primitive-type-or-lose ',type))) - ,@(mapcar - (lambda (kind) - (let ((slot (or (cdr (assoc kind - *primitive-type-slot-alist*)) - (error "unknown kind: ~S" kind)))) - `(setf (,slot ,n-type) ,n-vop))) - kinds))) - types) + (lambda (type) + `(let ((,n-type (primitive-type-or-lose ',type))) + ,@(mapcar + (lambda (kind) + (let ((slot (or (cdr (assoc kind + *primitive-type-slot-alist*)) + (error "unknown kind: ~S" kind)))) + `(setf (,slot ,n-type) ,n-vop))) + kinds))) + types) nil))) ;;; Return true if SC is either one of PTYPE's SC's, or one of those @@ -353,11 +353,11 @@ (let ((scn (sc-number sc))) (dolist (allowed (primitive-type-scs ptype) nil) (when (eql allowed scn) - (return t)) + (return t)) (let ((allowed-sc (svref *backend-meta-sc-numbers* allowed))) - (when (or (member sc (sc-alternate-scs allowed-sc)) - (member sc (sc-constant-scs allowed-sc))) - (return t)))))) + (when (or (member sc (sc-alternate-scs allowed-sc)) + (member sc (sc-constant-scs allowed-sc))) + (return t)))))) ;;;; VOP definition structures ;;;; @@ -369,8 +369,8 @@ ;;; A VOP-PARSE object holds everything we need to know about a VOP at ;;; meta-compile time. (def!struct (vop-parse - (:make-load-form-fun just-dump-it-normally) - #-sb-xc-host (:pure t)) + (:make-load-form-fun just-dump-it-normally) + #-sb-xc-host (:pure t)) ;; the name of this VOP (name nil :type symbol) ;; If true, then the name of the VOP we inherit from. @@ -456,14 +456,14 @@ ;;; operand or temporary at meta-compile time. Besides the obvious ;;; stuff, we also store the names of per-operand temporaries here. (def!struct (operand-parse - (:make-load-form-fun just-dump-it-normally) - #-sb-xc-host (:pure t)) + (:make-load-form-fun just-dump-it-normally) + #-sb-xc-host (:pure t)) ;; name of the operand (which we bind to the TN) (name nil :type symbol) ;; the way this operand is used: (kind (missing-arg) - :type (member :argument :result :temporary - :more-argument :more-result)) + :type (member :argument :result :temporary + :more-argument :more-result)) ;; If true, the name of an operand that this operand is targeted to. ;; This is only meaningful in :ARGUMENT and :TEMPORARY operands. (target nil :type (or symbol null)) @@ -505,16 +505,16 @@ ;;; the operand kind isn't one of the specified Kinds. If Error-P is ;;; NIL, just return NIL if there is no such operand. (defun find-operand (name parse &optional - (kinds '(:argument :result :temporary)) - (error-p t)) + (kinds '(:argument :result :temporary)) + (error-p t)) (declare (symbol name) (type vop-parse parse) (list kinds)) (let ((found (find name (vop-parse-operands parse) - :key #'operand-parse-name))) + :key #'operand-parse-name))) (if found - (unless (member (operand-parse-kind found) kinds) - (error "Operand ~S isn't one of these kinds: ~S." name kinds)) - (when error-p - (error "~S is not an operand to ~S." name (vop-parse-name parse)))) + (unless (member (operand-parse-kind found) kinds) + (error "Operand ~S isn't one of these kinds: ~S." name kinds)) + (when error-p + (error "~S is not an operand to ~S." name (vop-parse-name parse)))) found)) ;;; Get the VOP-PARSE structure for NAME or die trying. For all @@ -523,7 +523,7 @@ (defun vop-parse-or-lose (name) (the vop-parse (or (gethash name *backend-parsed-vops*) - (error "~S is not the name of a defined VOP." name)))) + (error "~S is not the name of a defined VOP." name)))) ;;; Return a list of LET-forms to parse a TN-REF list into the temps ;;; specified by the operand-parse structures. MORE-OPERAND is the @@ -534,12 +534,12 @@ (collect ((res)) (let ((prev refs)) (dolist (op operands) - (let ((n-ref (operand-parse-temp op))) - (res `(,n-ref ,prev)) - (setq prev `(tn-ref-across ,n-ref)))) + (let ((n-ref (operand-parse-temp op))) + (res `(,n-ref ,prev)) + (setq prev `(tn-ref-across ,n-ref)))) (when more-operand - (res `(,(operand-parse-name more-operand) ,prev)))) + (res `(,(operand-parse-name more-operand) ,prev)))) (res))) ;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-REF @@ -558,7 +558,7 @@ (error "extra junk at end of ~S" spec)) (let ((thing (elt spec n))) (unless (typep thing type) - (error "~:R argument is not a ~S: ~S" n type spec)) + (error "~:R argument is not a ~S: ~S" n type spec)) thing))) ;;;; time specs @@ -571,157 +571,157 @@ (defun parse-time-spec (spec) (let ((dspec (if (atom spec) (list spec 0) spec))) (unless (and (= (length dspec) 2) - (typep (second dspec) 'unsigned-byte)) + (typep (second dspec) 'unsigned-byte)) (error "malformed time specifier: ~S" spec)) (cons (case (first dspec) - (:load 0) - (:argument 1) - (:eval 2) - (:result 3) - (:save 4) - (t - (error "unknown phase in time specifier: ~S" spec))) - (second dspec)))) + (:load 0) + (:argument 1) + (:eval 2) + (:result 3) + (:save 4) + (t + (error "unknown phase in time specifier: ~S" spec))) + (second dspec)))) ;;; Return true if the time spec X is the same or later time than Y. (defun time-spec-order (x y) (or (> (car x) (car y)) (and (= (car x) (car y)) - (>= (cdr x) (cdr y))))) + (>= (cdr x) (cdr y))))) ;;;; generation of emit functions (defun compute-temporaries-description (parse) (let ((temps (vop-parse-temps parse)) - (element-type '(unsigned-byte 16))) + (element-type '(unsigned-byte 16))) (when temps (let ((results (make-specializable-array - (length temps) - :element-type element-type)) - (index 0)) - (dolist (temp temps) - (declare (type operand-parse temp)) - (let ((sc (operand-parse-sc temp)) - (offset (operand-parse-offset temp))) - (aver sc) - (setf (aref results index) - (if offset - (+ (ash offset (1+ sc-bits)) - (ash (meta-sc-number-or-lose sc) 1) - 1) - (ash (meta-sc-number-or-lose sc) 1)))) - (incf index)) - ;; KLUDGE: As in the other COERCEs wrapped around with - ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING, - ;; this coercion could be removed by a sufficiently smart - ;; compiler, but I dunno whether Python is that smart. It - ;; would be good to check this and help it if it's not smart - ;; enough to remove it for itself. However, it's probably not - ;; urgent, since the overhead of an extra no-op conversion is - ;; unlikely to be large compared to consing and corresponding - ;; GC. -- WHN ca. 19990701 - `(coerce ,results '(specializable-vector ,element-type)))))) + (length temps) + :element-type element-type)) + (index 0)) + (dolist (temp temps) + (declare (type operand-parse temp)) + (let ((sc (operand-parse-sc temp)) + (offset (operand-parse-offset temp))) + (aver sc) + (setf (aref results index) + (if offset + (+ (ash offset (1+ sc-bits)) + (ash (meta-sc-number-or-lose sc) 1) + 1) + (ash (meta-sc-number-or-lose sc) 1)))) + (incf index)) + ;; KLUDGE: As in the other COERCEs wrapped around with + ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING, + ;; this coercion could be removed by a sufficiently smart + ;; compiler, but I dunno whether Python is that smart. It + ;; would be good to check this and help it if it's not smart + ;; enough to remove it for itself. However, it's probably not + ;; urgent, since the overhead of an extra no-op conversion is + ;; unlikely to be large compared to consing and corresponding + ;; GC. -- WHN ca. 19990701 + `(coerce ,results '(specializable-vector ,element-type)))))) (defun compute-ref-ordering (parse) (let* ((num-args (+ (length (vop-parse-args parse)) - (if (vop-parse-more-args parse) 1 0))) - (num-results (+ (length (vop-parse-results parse)) - (if (vop-parse-more-results parse) 1 0))) - (index 0)) + (if (vop-parse-more-args parse) 1 0))) + (num-results (+ (length (vop-parse-results parse)) + (if (vop-parse-more-results parse) 1 0))) + (index 0)) (collect ((refs) (targets)) (dolist (op (vop-parse-operands parse)) - (when (operand-parse-target op) - (unless (member (operand-parse-kind op) '(:argument :temporary)) - (error "cannot target a ~S operand: ~S" (operand-parse-kind op) - (operand-parse-name op))) - (let ((target (find-operand (operand-parse-target op) parse - '(:temporary :result)))) - ;; KLUDGE: These formulas must be consistent with those in - ;; %EMIT-GENERIC-VOP, and this is currently maintained by - ;; hand. -- WHN 2002-01-30, paraphrasing APD - (targets (+ (* index max-vop-tn-refs) - (ecase (operand-parse-kind target) - (:result - (+ (position-or-lose target - (vop-parse-results parse)) - num-args)) - (:temporary - (+ (* (position-or-lose target - (vop-parse-temps parse)) - 2) + (when (operand-parse-target op) + (unless (member (operand-parse-kind op) '(:argument :temporary)) + (error "cannot target a ~S operand: ~S" (operand-parse-kind op) + (operand-parse-name op))) + (let ((target (find-operand (operand-parse-target op) parse + '(:temporary :result)))) + ;; KLUDGE: These formulas must be consistent with those in + ;; %EMIT-GENERIC-VOP, and this is currently maintained by + ;; hand. -- WHN 2002-01-30, paraphrasing APD + (targets (+ (* index max-vop-tn-refs) + (ecase (operand-parse-kind target) + (:result + (+ (position-or-lose target + (vop-parse-results parse)) + num-args)) + (:temporary + (+ (* (position-or-lose target + (vop-parse-temps parse)) + 2) 1 - num-args - num-results))))))) - (let ((born (operand-parse-born op)) - (dies (operand-parse-dies op))) - (ecase (operand-parse-kind op) - (:argument - (refs (cons (cons dies nil) index))) - (:more-argument - (refs (cons (cons dies nil) index))) - (:result - (refs (cons (cons born t) index))) - (:more-result - (refs (cons (cons born t) index))) - (:temporary - (refs (cons (cons dies nil) index)) - (incf index) - (refs (cons (cons born t) index)))) - (incf index))) + num-args + num-results))))))) + (let ((born (operand-parse-born op)) + (dies (operand-parse-dies op))) + (ecase (operand-parse-kind op) + (:argument + (refs (cons (cons dies nil) index))) + (:more-argument + (refs (cons (cons dies nil) index))) + (:result + (refs (cons (cons born t) index))) + (:more-result + (refs (cons (cons born t) index))) + (:temporary + (refs (cons (cons dies nil) index)) + (incf index) + (refs (cons (cons born t) index)))) + (incf index))) (let* ((sorted (sort (refs) - (lambda (x y) - (let ((x-time (car x)) - (y-time (car y))) - (if (time-spec-order x-time y-time) - (if (time-spec-order y-time x-time) - (and (not (cdr x)) (cdr y)) - nil) - t))) - :key #'car)) - ;; :REF-ORDERING element type - ;; - ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right - (oe-type '(unsigned-byte 8)) - ;; :TARGETS element-type - ;; - ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does - ;; not correspond to the definition in - ;; src/compiler/vop.lisp. - (te-type '(unsigned-byte 16)) - (ordering (make-specializable-array - (length sorted) - :element-type oe-type))) - (let ((index 0)) - (dolist (ref sorted) - (setf (aref ordering index) (cdr ref)) - (incf index))) - `(:num-args ,num-args - :num-results ,num-results - ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper - ;; here around the result returned by - ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to - ;; help with cross-compilation. "A sufficiently smart - ;; compiler" should be able to optimize all this away in the - ;; final target Lisp, leaving a single MAKE-ARRAY with no - ;; subsequent coercion. However, I don't know whether Python - ;; is that smart. (Can it figure out the return type of - ;; MAKE-ARRAY? Does it know that COERCE can be optimized - ;; away if the input type is known to be the same as the - ;; COERCEd-to type?) At some point it would be good to test - ;; to see whether this construct is in fact causing run-time - ;; overhead, and fix it if so. (Some declarations of the - ;; types returned by MAKE-ARRAY might be enough to fix it.) - ;; However, it's probably not urgent to fix this, since it's - ;; hard to imagine that any overhead caused by calling - ;; COERCE and letting it decide to bail out could be large - ;; compared to the cost of consing and GCing the vectors in - ;; the first place. -- WHN ca. 19990701 - :ref-ordering (coerce ',ordering - '(specializable-vector ,oe-type)) - ,@(when (targets) - `(:targets (coerce ',(targets) - '(specializable-vector ,te-type))))))))) + (lambda (x y) + (let ((x-time (car x)) + (y-time (car y))) + (if (time-spec-order x-time y-time) + (if (time-spec-order y-time x-time) + (and (not (cdr x)) (cdr y)) + nil) + t))) + :key #'car)) + ;; :REF-ORDERING element type + ;; + ;; KLUDGE: was (MOD #.MAX-VOP-TN-REFS), which is still right + (oe-type '(unsigned-byte 8)) + ;; :TARGETS element-type + ;; + ;; KLUDGE: was (MOD #.(* MAX-VOP-TN-REFS 2)), which does + ;; not correspond to the definition in + ;; src/compiler/vop.lisp. + (te-type '(unsigned-byte 16)) + (ordering (make-specializable-array + (length sorted) + :element-type oe-type))) + (let ((index 0)) + (dolist (ref sorted) + (setf (aref ordering index) (cdr ref)) + (incf index))) + `(:num-args ,num-args + :num-results ,num-results + ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper + ;; here around the result returned by + ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to + ;; help with cross-compilation. "A sufficiently smart + ;; compiler" should be able to optimize all this away in the + ;; final target Lisp, leaving a single MAKE-ARRAY with no + ;; subsequent coercion. However, I don't know whether Python + ;; is that smart. (Can it figure out the return type of + ;; MAKE-ARRAY? Does it know that COERCE can be optimized + ;; away if the input type is known to be the same as the + ;; COERCEd-to type?) At some point it would be good to test + ;; to see whether this construct is in fact causing run-time + ;; overhead, and fix it if so. (Some declarations of the + ;; types returned by MAKE-ARRAY might be enough to fix it.) + ;; However, it's probably not urgent to fix this, since it's + ;; hard to imagine that any overhead caused by calling + ;; COERCE and letting it decide to bail out could be large + ;; compared to the cost of consing and GCing the vectors in + ;; the first place. -- WHN ca. 19990701 + :ref-ordering (coerce ',ordering + '(specializable-vector ,oe-type)) + ,@(when (targets) + `(:targets (coerce ',(targets) + '(specializable-vector ,te-type))))))))) (defun make-emit-function-and-friends (parse) `(:emit-function #'emit-generic-vop @@ -738,38 +738,38 @@ (collect ((funs)) (dolist (sc-name (operand-parse-scs op)) (let* ((sc (meta-sc-or-lose sc-name)) - (scn (sc-number sc)) - (load-scs (append (when load-p - (sc-constant-scs sc)) - (sc-alternate-scs sc)))) - (cond - (load-scs - (dolist (alt load-scs) - (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq) - (let* ((altn (sc-number alt)) - (name (if load-p - (svref (sc-move-funs sc) altn) - (svref (sc-move-funs alt) scn))) - (found (or (assoc alt (funs) :test #'member) - (rassoc name (funs))))) - (unless name - (error "no move function defined to ~:[save~;load~] SC ~S ~ + (scn (sc-number sc)) + (load-scs (append (when load-p + (sc-constant-scs sc)) + (sc-alternate-scs sc)))) + (cond + (load-scs + (dolist (alt load-scs) + (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq) + (let* ((altn (sc-number alt)) + (name (if load-p + (svref (sc-move-funs sc) altn) + (svref (sc-move-funs alt) scn))) + (found (or (assoc alt (funs) :test #'member) + (rassoc name (funs))))) + (unless name + (error "no move function defined to ~:[save~;load~] SC ~S ~ ~:[to~;from~] from SC ~S" - load-p sc-name load-p (sc-name alt))) - - (cond (found - (unless (eq (cdr found) name) - (error "can't tell whether to ~:[save~;load~]~@ + load-p sc-name load-p (sc-name alt))) + + (cond (found + (unless (eq (cdr found) name) + (error "can't tell whether to ~:[save~;load~]~@ with ~S or ~S when operand is in SC ~S" - load-p name (cdr found) (sc-name alt))) - (pushnew alt (car found))) - (t - (funs (cons (list alt) name)))))))) - ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded))) - (t - (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@ + load-p name (cdr found) (sc-name alt))) + (pushnew alt (car found))) + (t + (funs (cons (list alt) name)))))))) + ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded))) + (t + (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@ mentioned in the restriction for operand ~S" - sc-name load-p (operand-parse-name op)))))) + sc-name load-p (operand-parse-name op)))))) (funs))) ;;; Return a form to load/save the specified operand when it has a @@ -780,30 +780,30 @@ ;;; of the operand TN's type to see which move function to use. (defun call-move-fun (parse op load-p) (let ((funs (find-move-funs op load-p)) - (load-tn (operand-parse-load-tn op))) + (load-tn (operand-parse-load-tn op))) (if funs - (let* ((tn `(tn-ref-tn ,(operand-parse-temp op))) - (n-vop (or (vop-parse-vop-var parse) - (setf (vop-parse-vop-var parse) '.vop.))) - (form (if (rest funs) - `(sc-case ,tn - ,@(mapcar (lambda (x) - `(,(mapcar #'sc-name (car x)) - ,(if load-p - `(,(cdr x) ,n-vop ,tn - ,load-tn) - `(,(cdr x) ,n-vop ,load-tn - ,tn)))) - funs)) - (if load-p - `(,(cdr (first funs)) ,n-vop ,tn ,load-tn) - `(,(cdr (first funs)) ,n-vop ,load-tn ,tn))))) - (if (eq (operand-parse-load op) t) - `(when ,load-tn ,form) - `(when (eq ,load-tn ,(operand-parse-name op)) - ,form))) - `(when ,load-tn - (error "load TN allocated, but no move function?~@ + (let* ((tn `(tn-ref-tn ,(operand-parse-temp op))) + (n-vop (or (vop-parse-vop-var parse) + (setf (vop-parse-vop-var parse) '.vop.))) + (form (if (rest funs) + `(sc-case ,tn + ,@(mapcar (lambda (x) + `(,(mapcar #'sc-name (car x)) + ,(if load-p + `(,(cdr x) ,n-vop ,tn + ,load-tn) + `(,(cdr x) ,n-vop ,load-tn + ,tn)))) + funs)) + (if load-p + `(,(cdr (first funs)) ,n-vop ,tn ,load-tn) + `(,(cdr (first funs)) ,n-vop ,load-tn ,tn))))) + (if (eq (operand-parse-load op) t) + `(when ,load-tn ,form) + `(when (eq ,load-tn ,(operand-parse-name op)) + ,form))) + `(when ,load-tn + (error "load TN allocated, but no move function?~@ VM definition is inconsistent, recompile and try again."))))) ;;; Return the TN that we should bind to the operand's var in the @@ -811,88 +811,88 @@ ;;; test expression. (defun decide-to-load (parse op) (let ((load (operand-parse-load op)) - (load-tn (operand-parse-load-tn op)) - (temp (operand-parse-temp op))) + (load-tn (operand-parse-load-tn op)) + (temp (operand-parse-temp op))) (if (eq load t) - `(or ,load-tn (tn-ref-tn ,temp)) - (collect ((binds) - (ignores)) - (dolist (x (vop-parse-operands parse)) - (when (member (operand-parse-kind x) '(:argument :result)) - (let ((name (operand-parse-name x))) - (binds `(,name (tn-ref-tn ,(operand-parse-temp x)))) - (ignores name)))) - `(if (and ,load-tn - (let ,(binds) - (declare (ignorable ,@(ignores))) - ,load)) - ,load-tn - (tn-ref-tn ,temp)))))) + `(or ,load-tn (tn-ref-tn ,temp)) + (collect ((binds) + (ignores)) + (dolist (x (vop-parse-operands parse)) + (when (member (operand-parse-kind x) '(:argument :result)) + (let ((name (operand-parse-name x))) + (binds `(,name (tn-ref-tn ,(operand-parse-temp x)))) + (ignores name)))) + `(if (and ,load-tn + (let ,(binds) + (declare (ignorable ,@(ignores))) + ,load)) + ,load-tn + (tn-ref-tn ,temp)))))) ;;; Make a lambda that parses the VOP TN-REFS, does automatic operand ;;; loading, and runs the appropriate code generator. (defun make-generator-function (parse) (declare (type vop-parse parse)) (let ((n-vop (vop-parse-vop-var parse)) - (operands (vop-parse-operands parse)) - (n-info (gensym)) (n-variant (gensym))) + (operands (vop-parse-operands parse)) + (n-info (gensym)) (n-variant (gensym))) (collect ((binds) - (loads) - (saves)) + (loads) + (saves)) (dolist (op operands) - (ecase (operand-parse-kind op) - ((:argument :result) - (let ((temp (operand-parse-temp op)) - (name (operand-parse-name op))) - (cond ((and (operand-parse-load op) (operand-parse-scs op)) - (binds `(,(operand-parse-load-tn op) - (tn-ref-load-tn ,temp))) - (binds `(,name ,(decide-to-load parse op))) - (if (eq (operand-parse-kind op) :argument) - (loads (call-move-fun parse op t)) - (saves (call-move-fun parse op nil)))) - (t - (binds `(,name (tn-ref-tn ,temp))))))) - (:temporary - (binds `(,(operand-parse-name op) - (tn-ref-tn ,(operand-parse-temp op))))) - ((:more-argument :more-result)))) + (ecase (operand-parse-kind op) + ((:argument :result) + (let ((temp (operand-parse-temp op)) + (name (operand-parse-name op))) + (cond ((and (operand-parse-load op) (operand-parse-scs op)) + (binds `(,(operand-parse-load-tn op) + (tn-ref-load-tn ,temp))) + (binds `(,name ,(decide-to-load parse op))) + (if (eq (operand-parse-kind op) :argument) + (loads (call-move-fun parse op t)) + (saves (call-move-fun parse op nil)))) + (t + (binds `(,name (tn-ref-tn ,temp))))))) + (:temporary + (binds `(,(operand-parse-name op) + (tn-ref-tn ,(operand-parse-temp op))))) + ((:more-argument :more-result)))) `(lambda (,n-vop) - (let* (,@(access-operands (vop-parse-args parse) - (vop-parse-more-args parse) - `(vop-args ,n-vop)) - ,@(access-operands (vop-parse-results parse) - (vop-parse-more-results parse) - `(vop-results ,n-vop)) - ,@(access-operands (vop-parse-temps parse) nil - `(vop-temps ,n-vop)) - ,@(when (vop-parse-info-args parse) - `((,n-info (vop-codegen-info ,n-vop)) - ,@(mapcar (lambda (x) `(,x (pop ,n-info))) - (vop-parse-info-args parse)))) - ,@(when (vop-parse-variant-vars parse) - `((,n-variant (vop-info-variant (vop-info ,n-vop))) - ,@(mapcar (lambda (x) `(,x (pop ,n-variant))) - (vop-parse-variant-vars parse)))) - ,@(when (vop-parse-node-var parse) - `((,(vop-parse-node-var parse) (vop-node ,n-vop)))) - ,@(binds)) - (declare (ignore ,@(vop-parse-ignores parse))) - ,@(loads) - (sb!assem:assemble (*code-segment* ,n-vop) - ,@(vop-parse-body parse)) - ,@(saves)))))) + (let* (,@(access-operands (vop-parse-args parse) + (vop-parse-more-args parse) + `(vop-args ,n-vop)) + ,@(access-operands (vop-parse-results parse) + (vop-parse-more-results parse) + `(vop-results ,n-vop)) + ,@(access-operands (vop-parse-temps parse) nil + `(vop-temps ,n-vop)) + ,@(when (vop-parse-info-args parse) + `((,n-info (vop-codegen-info ,n-vop)) + ,@(mapcar (lambda (x) `(,x (pop ,n-info))) + (vop-parse-info-args parse)))) + ,@(when (vop-parse-variant-vars parse) + `((,n-variant (vop-info-variant (vop-info ,n-vop))) + ,@(mapcar (lambda (x) `(,x (pop ,n-variant))) + (vop-parse-variant-vars parse)))) + ,@(when (vop-parse-node-var parse) + `((,(vop-parse-node-var parse) (vop-node ,n-vop)))) + ,@(binds)) + (declare (ignore ,@(vop-parse-ignores parse))) + ,@(loads) + (sb!assem:assemble (*code-segment* ,n-vop) + ,@(vop-parse-body parse)) + ,@(saves)))))) (defvar *parse-vop-operand-count*) (defun make-operand-parse-temp () ;; FIXME: potentially causes breakage in contribs from locked ;; packages. (intern (format nil "OPERAND-PARSE-TEMP-~D" *parse-vop-operand-count*) - (symbol-package '*parse-vop-operand-count*))) + (symbol-package '*parse-vop-operand-count*))) (defun make-operand-parse-load-tn () (intern (format nil "OPERAND-PARSE-LOAD-TN-~D" *parse-vop-operand-count*) - (symbol-package '*parse-vop-operand-count*))) + (symbol-package '*parse-vop-operand-count*))) ;;; Given a list of operand specifications as given to DEFINE-VOP, ;;; return a list of OPERAND-PARSE structures describing the fixed @@ -901,92 +901,92 @@ ;;; operand of the same name. (defun !parse-vop-operands (parse specs kind) (declare (list specs) - (type (member :argument :result) kind)) + (type (member :argument :result) kind)) (let ((num -1) - (more nil)) + (more nil)) (collect ((operands)) (dolist (spec specs) - (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec))) - (error "malformed operand specifier: ~S" spec)) - (when more - (error "The MORE operand isn't the last operand: ~S" specs)) - (incf *parse-vop-operand-count*) - (let* ((name (first spec)) - (old (if (vop-parse-inherits parse) - (find-operand name - (vop-parse-or-lose - (vop-parse-inherits parse)) - (list kind) - nil) - nil)) - (res (if old - (make-operand-parse - :name name - :kind kind - :target (operand-parse-target old) - :born (operand-parse-born old) - :dies (operand-parse-dies old) - :scs (operand-parse-scs old) - :load-tn (operand-parse-load-tn old) - :load (operand-parse-load old)) - (ecase kind - (:argument - (make-operand-parse - :name (first spec) - :kind :argument - :born (parse-time-spec :load) - :dies (parse-time-spec `(:argument ,(incf num))))) - (:result - (make-operand-parse - :name (first spec) - :kind :result - :born (parse-time-spec `(:result ,(incf num))) - :dies (parse-time-spec :save))))))) - (do ((key (rest spec) (cddr key))) - ((null key)) - (let ((value (second key))) - (case (first key) - (:scs - (aver (typep value 'list)) - (setf (operand-parse-scs res) (remove-duplicates value))) - (:load-tn - (aver (typep value 'symbol)) - (setf (operand-parse-load-tn res) value)) - (:load-if - (setf (operand-parse-load res) value)) - (:more - (aver (typep value 'boolean)) - (setf (operand-parse-kind res) - (if (eq kind :argument) :more-argument :more-result)) - (setf (operand-parse-load res) nil) - (setq more res)) - (:target - (aver (typep value 'symbol)) - (setf (operand-parse-target res) value)) - (:from - (unless (eq kind :result) - (error "can only specify :FROM in a result: ~S" spec)) - (setf (operand-parse-born res) (parse-time-spec value))) - (:to - (unless (eq kind :argument) - (error "can only specify :TO in an argument: ~S" spec)) - (setf (operand-parse-dies res) (parse-time-spec value))) - (t - (error "unknown keyword in operand specifier: ~S" spec))))) - - (cond ((not more) - (operands res)) - ((operand-parse-target more) - (error "cannot specify :TARGET in a :MORE operand")) - ((operand-parse-load more) - (error "cannot specify :LOAD-IF in a :MORE operand"))))) + (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec))) + (error "malformed operand specifier: ~S" spec)) + (when more + (error "The MORE operand isn't the last operand: ~S" specs)) + (incf *parse-vop-operand-count*) + (let* ((name (first spec)) + (old (if (vop-parse-inherits parse) + (find-operand name + (vop-parse-or-lose + (vop-parse-inherits parse)) + (list kind) + nil) + nil)) + (res (if old + (make-operand-parse + :name name + :kind kind + :target (operand-parse-target old) + :born (operand-parse-born old) + :dies (operand-parse-dies old) + :scs (operand-parse-scs old) + :load-tn (operand-parse-load-tn old) + :load (operand-parse-load old)) + (ecase kind + (:argument + (make-operand-parse + :name (first spec) + :kind :argument + :born (parse-time-spec :load) + :dies (parse-time-spec `(:argument ,(incf num))))) + (:result + (make-operand-parse + :name (first spec) + :kind :result + :born (parse-time-spec `(:result ,(incf num))) + :dies (parse-time-spec :save))))))) + (do ((key (rest spec) (cddr key))) + ((null key)) + (let ((value (second key))) + (case (first key) + (:scs + (aver (typep value 'list)) + (setf (operand-parse-scs res) (remove-duplicates value))) + (:load-tn + (aver (typep value 'symbol)) + (setf (operand-parse-load-tn res) value)) + (:load-if + (setf (operand-parse-load res) value)) + (:more + (aver (typep value 'boolean)) + (setf (operand-parse-kind res) + (if (eq kind :argument) :more-argument :more-result)) + (setf (operand-parse-load res) nil) + (setq more res)) + (:target + (aver (typep value 'symbol)) + (setf (operand-parse-target res) value)) + (:from + (unless (eq kind :result) + (error "can only specify :FROM in a result: ~S" spec)) + (setf (operand-parse-born res) (parse-time-spec value))) + (:to + (unless (eq kind :argument) + (error "can only specify :TO in an argument: ~S" spec)) + (setf (operand-parse-dies res) (parse-time-spec value))) + (t + (error "unknown keyword in operand specifier: ~S" spec))))) + + (cond ((not more) + (operands res)) + ((operand-parse-target more) + (error "cannot specify :TARGET in a :MORE operand")) + ((operand-parse-load more) + (error "cannot specify :LOAD-IF in a :MORE operand"))))) (values (the list (operands)) more)))) ;;; Parse a temporary specification, putting the OPERAND-PARSE ;;; structures in the PARSE structure. (defun parse-temporary (spec parse) (declare (list spec) - (type vop-parse parse)) + (type vop-parse parse)) (let ((len (length spec))) (unless (>= len 2) (error "malformed temporary spec: ~S" spec)) @@ -998,65 +998,65 @@ (warn "temporary spec allocates no temps:~% ~S" spec)) (dolist (name (cddr spec)) (unless (symbolp name) - (error "bad temporary name: ~S" name)) + (error "bad temporary name: ~S" name)) (incf *parse-vop-operand-count*) (let ((res (make-operand-parse :name name - :kind :temporary - :born (parse-time-spec :load) - :dies (parse-time-spec :save)))) - (do ((opt (second spec) (cddr opt))) - ((null opt)) - (case (first opt) - (:target - (setf (operand-parse-target res) - (vop-spec-arg opt 'symbol 1 nil))) - (:sc - (setf (operand-parse-sc res) - (vop-spec-arg opt 'symbol 1 nil))) - (:offset - (let ((offset (eval (second opt)))) - (aver (typep offset 'unsigned-byte)) - (setf (operand-parse-offset res) offset))) - (:from - (setf (operand-parse-born res) (parse-time-spec (second opt)))) - (:to - (setf (operand-parse-dies res) (parse-time-spec (second opt)))) - ;; backward compatibility... - (:scs - (let ((scs (vop-spec-arg opt 'list 1 nil))) - (unless (= (length scs) 1) - (error "must specify exactly one SC for a temporary")) - (setf (operand-parse-sc res) (first scs)))) - (:type) - (t - (error "unknown temporary option: ~S" opt)))) - - (unless (and (time-spec-order (operand-parse-dies res) - (operand-parse-born res)) - (not (time-spec-order (operand-parse-born res) - (operand-parse-dies res)))) - (error "Temporary lifetime doesn't begin before it ends: ~S" spec)) - - (unless (operand-parse-sc res) - (error "must specify :SC for all temporaries: ~S" spec)) - - (setf (vop-parse-temps parse) - (cons res - (remove name (vop-parse-temps parse) - :key #'operand-parse-name)))))) + :kind :temporary + :born (parse-time-spec :load) + :dies (parse-time-spec :save)))) + (do ((opt (second spec) (cddr opt))) + ((null opt)) + (case (first opt) + (:target + (setf (operand-parse-target res) + (vop-spec-arg opt 'symbol 1 nil))) + (:sc + (setf (operand-parse-sc res) + (vop-spec-arg opt 'symbol 1 nil))) + (:offset + (let ((offset (eval (second opt)))) + (aver (typep offset 'unsigned-byte)) + (setf (operand-parse-offset res) offset))) + (:from + (setf (operand-parse-born res) (parse-time-spec (second opt)))) + (:to + (setf (operand-parse-dies res) (parse-time-spec (second opt)))) + ;; backward compatibility... + (:scs + (let ((scs (vop-spec-arg opt 'list 1 nil))) + (unless (= (length scs) 1) + (error "must specify exactly one SC for a temporary")) + (setf (operand-parse-sc res) (first scs)))) + (:type) + (t + (error "unknown temporary option: ~S" opt)))) + + (unless (and (time-spec-order (operand-parse-dies res) + (operand-parse-born res)) + (not (time-spec-order (operand-parse-born res) + (operand-parse-dies res)))) + (error "Temporary lifetime doesn't begin before it ends: ~S" spec)) + + (unless (operand-parse-sc res) + (error "must specify :SC for all temporaries: ~S" spec)) + + (setf (vop-parse-temps parse) + (cons res + (remove name (vop-parse-temps parse) + :key #'operand-parse-name)))))) (values)) (defun compute-parse-vop-operand-count (parse) (declare (type vop-parse parse)) (labels ((compute-count-aux (parse) - (declare (type vop-parse parse)) - (if (null (vop-parse-inherits parse)) - (length (vop-parse-operands parse)) - (+ (length (vop-parse-operands parse)) - (compute-count-aux - (vop-parse-or-lose (vop-parse-inherits parse))))))) + (declare (type vop-parse parse)) + (if (null (vop-parse-inherits parse)) + (length (vop-parse-operands parse)) + (+ (length (vop-parse-operands parse)) + (compute-count-aux + (vop-parse-or-lose (vop-parse-inherits parse))))))) (if (null (vop-parse-inherits parse)) - 0 + 0 (compute-count-aux (vop-parse-or-lose (vop-parse-inherits parse)))))) ;;; the top level parse function: clobber PARSE to represent the @@ -1066,81 +1066,81 @@ (let ((*parse-vop-operand-count* (compute-parse-vop-operand-count parse))) (dolist (spec specs) (unless (consp spec) - (error "malformed option specification: ~S" spec)) + (error "malformed option specification: ~S" spec)) (case (first spec) - (:args - (multiple-value-bind (fixed more) - (!parse-vop-operands parse (rest spec) :argument) - (setf (vop-parse-args parse) fixed) - (setf (vop-parse-more-args parse) more))) - (:results - (multiple-value-bind (fixed more) - (!parse-vop-operands parse (rest spec) :result) - (setf (vop-parse-results parse) fixed) - (setf (vop-parse-more-results parse) more)) - (setf (vop-parse-conditional-p parse) nil)) - (:conditional - (setf (vop-parse-result-types parse) ()) - (setf (vop-parse-results parse) ()) - (setf (vop-parse-more-results parse) nil) - (setf (vop-parse-conditional-p parse) t)) - (:temporary - (parse-temporary spec parse)) - (:generator - (setf (vop-parse-cost parse) - (vop-spec-arg spec 'unsigned-byte 1 nil)) - (setf (vop-parse-body parse) (cddr spec))) - (:effects - (setf (vop-parse-effects parse) (rest spec))) - (:affected - (setf (vop-parse-affected parse) (rest spec))) - (:info - (setf (vop-parse-info-args parse) (rest spec))) - (:ignore - (setf (vop-parse-ignores parse) (rest spec))) - (:variant - (setf (vop-parse-variant parse) (rest spec))) - (:variant-vars - (let ((vars (rest spec))) - (setf (vop-parse-variant-vars parse) vars) - (setf (vop-parse-variant parse) - (make-list (length vars) :initial-element nil)))) - (:variant-cost - (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte))) - (:vop-var - (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol))) - (:move-args - (setf (vop-parse-move-args parse) - (vop-spec-arg spec '(member nil :local-call :full-call - :known-return)))) - (:node-var - (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol))) - (:note - (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null)))) - (:arg-types - (setf (vop-parse-arg-types parse) - (!parse-vop-operand-types (rest spec) t))) - (:result-types - (setf (vop-parse-result-types parse) - (!parse-vop-operand-types (rest spec) nil))) - (:translate - (setf (vop-parse-translate parse) (rest spec))) - (:guard - (setf (vop-parse-guard parse) (vop-spec-arg spec t))) - ;; FIXME: :LTN-POLICY would be a better name for this. It - ;; would probably be good to leave it unchanged for a while, - ;; though, at least until the first port to some other - ;; architecture, since the renaming would be a change to the - ;; interface between - (:policy - (setf (vop-parse-ltn-policy parse) - (vop-spec-arg spec 'ltn-policy))) - (:save-p - (setf (vop-parse-save-p parse) - (vop-spec-arg spec - '(member t nil :compute-only :force-to-stack)))) - (t - (error "unknown option specifier: ~S" (first spec))))) + (:args + (multiple-value-bind (fixed more) + (!parse-vop-operands parse (rest spec) :argument) + (setf (vop-parse-args parse) fixed) + (setf (vop-parse-more-args parse) more))) + (:results + (multiple-value-bind (fixed more) + (!parse-vop-operands parse (rest spec) :result) + (setf (vop-parse-results parse) fixed) + (setf (vop-parse-more-results parse) more)) + (setf (vop-parse-conditional-p parse) nil)) + (:conditional + (setf (vop-parse-result-types parse) ()) + (setf (vop-parse-results parse) ()) + (setf (vop-parse-more-results parse) nil) + (setf (vop-parse-conditional-p parse) t)) + (:temporary + (parse-temporary spec parse)) + (:generator + (setf (vop-parse-cost parse) + (vop-spec-arg spec 'unsigned-byte 1 nil)) + (setf (vop-parse-body parse) (cddr spec))) + (:effects + (setf (vop-parse-effects parse) (rest spec))) + (:affected + (setf (vop-parse-affected parse) (rest spec))) + (:info + (setf (vop-parse-info-args parse) (rest spec))) + (:ignore + (setf (vop-parse-ignores parse) (rest spec))) + (:variant + (setf (vop-parse-variant parse) (rest spec))) + (:variant-vars + (let ((vars (rest spec))) + (setf (vop-parse-variant-vars parse) vars) + (setf (vop-parse-variant parse) + (make-list (length vars) :initial-element nil)))) + (:variant-cost + (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte))) + (:vop-var + (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol))) + (:move-args + (setf (vop-parse-move-args parse) + (vop-spec-arg spec '(member nil :local-call :full-call + :known-return)))) + (:node-var + (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol))) + (:note + (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null)))) + (:arg-types + (setf (vop-parse-arg-types parse) + (!parse-vop-operand-types (rest spec) t))) + (:result-types + (setf (vop-parse-result-types parse) + (!parse-vop-operand-types (rest spec) nil))) + (:translate + (setf (vop-parse-translate parse) (rest spec))) + (:guard + (setf (vop-parse-guard parse) (vop-spec-arg spec t))) + ;; FIXME: :LTN-POLICY would be a better name for this. It + ;; would probably be good to leave it unchanged for a while, + ;; though, at least until the first port to some other + ;; architecture, since the renaming would be a change to the + ;; interface between + (:policy + (setf (vop-parse-ltn-policy parse) + (vop-spec-arg spec 'ltn-policy))) + (:save-p + (setf (vop-parse-save-p parse) + (vop-spec-arg spec + '(member t nil :compute-only :force-to-stack)))) + (t + (error "unknown option specifier: ~S" (first spec))))) (values))) ;;;; making costs and restrictions @@ -1156,42 +1156,42 @@ (defun compute-loading-costs (op load-p) (declare (type operand-parse op)) (let ((scs (operand-parse-scs op)) - (costs (make-array sc-number-limit :initial-element nil)) - (load-scs (make-array sc-number-limit :initial-element nil))) + (costs (make-array sc-number-limit :initial-element nil)) + (load-scs (make-array sc-number-limit :initial-element nil))) (dolist (sc-name scs) (let* ((load-sc (meta-sc-or-lose sc-name)) - (load-scn (sc-number load-sc))) - (setf (svref costs load-scn) 0) - (setf (svref load-scs load-scn) t) - (dolist (op-sc (append (when load-p - (sc-constant-scs load-sc)) - (sc-alternate-scs load-sc))) - (let* ((op-scn (sc-number op-sc)) - (load (if load-p - (aref (sc-load-costs load-sc) op-scn) - (aref (sc-load-costs op-sc) load-scn)))) - (unless load - (error "no move function defined to move ~:[from~;to~] SC ~ + (load-scn (sc-number load-sc))) + (setf (svref costs load-scn) 0) + (setf (svref load-scs load-scn) t) + (dolist (op-sc (append (when load-p + (sc-constant-scs load-sc)) + (sc-alternate-scs load-sc))) + (let* ((op-scn (sc-number op-sc)) + (load (if load-p + (aref (sc-load-costs load-sc) op-scn) + (aref (sc-load-costs op-sc) load-scn)))) + (unless load + (error "no move function defined to move ~:[from~;to~] SC ~ ~S~%~:[to~;from~] alternate or constant SC ~S" - load-p sc-name load-p (sc-name op-sc))) - - (let ((op-cost (svref costs op-scn))) - (when (or (not op-cost) (< load op-cost)) - (setf (svref costs op-scn) load))) - - (let ((op-load (svref load-scs op-scn))) - (unless (eq op-load t) - (pushnew load-scn (svref load-scs op-scn)))))) - - (dotimes (i sc-number-limit) - (unless (svref costs i) - (let ((op-sc (svref *backend-meta-sc-numbers* i))) - (when op-sc - (let ((cost (if load-p - (svref (sc-move-costs load-sc) i) - (svref (sc-move-costs op-sc) load-scn)))) - (when cost - (setf (svref costs i) cost))))))))) + load-p sc-name load-p (sc-name op-sc))) + + (let ((op-cost (svref costs op-scn))) + (when (or (not op-cost) (< load op-cost)) + (setf (svref costs op-scn) load))) + + (let ((op-load (svref load-scs op-scn))) + (unless (eq op-load t) + (pushnew load-scn (svref load-scs op-scn)))))) + + (dotimes (i sc-number-limit) + (unless (svref costs i) + (let ((op-sc (svref *backend-meta-sc-numbers* i))) + (when op-sc + (let ((cost (if load-p + (svref (sc-move-costs load-sc) i) + (svref (sc-move-costs op-sc) load-scn)))) + (when cost + (setf (svref costs i) cost))))))))) (values costs load-scs))) @@ -1211,35 +1211,35 @@ (defun compute-costs-and-restrictions-list (ops load-p) (declare (list ops)) (collect ((costs) - (scs)) + (scs)) (dolist (op ops) (multiple-value-bind (costs scs) (compute-loading-costs-if-any op load-p) - (costs costs) - (scs scs))) + (costs costs) + (scs scs))) (values (costs) (scs)))) (defun make-costs-and-restrictions (parse) (multiple-value-bind (arg-costs arg-scs) (compute-costs-and-restrictions-list (vop-parse-args parse) t) (multiple-value-bind (result-costs result-scs) - (compute-costs-and-restrictions-list (vop-parse-results parse) nil) + (compute-costs-and-restrictions-list (vop-parse-results parse) nil) `( - :cost ,(vop-parse-cost parse) - - :arg-costs ',arg-costs - :arg-load-scs ',arg-scs - :result-costs ',result-costs - :result-load-scs ',result-scs - - :more-arg-costs - ',(if (vop-parse-more-args parse) - (compute-loading-costs-if-any (vop-parse-more-args parse) t) - nil) - - :more-result-costs - ',(if (vop-parse-more-results parse) - (compute-loading-costs-if-any (vop-parse-more-results parse) nil) - nil))))) + :cost ,(vop-parse-cost parse) + + :arg-costs ',arg-costs + :arg-load-scs ',arg-scs + :result-costs ',result-costs + :result-load-scs ',result-scs + + :more-arg-costs + ',(if (vop-parse-more-args parse) + (compute-loading-costs-if-any (vop-parse-more-args parse) t) + nil) + + :more-result-costs + ',(if (vop-parse-more-results parse) + (compute-loading-costs-if-any (vop-parse-more-results parse) nil) + nil))))) ;;;; operand checking and stuff @@ -1248,47 +1248,47 @@ (defun !parse-vop-operand-types (specs args-p) (declare (list specs)) (labels ((parse-operand-type (spec) - (cond ((eq spec '*) spec) - ((symbolp spec) - (let ((alias (gethash spec - *backend-primitive-type-aliases*))) - (if alias - (parse-operand-type alias) - `(:or ,spec)))) - ((atom spec) - (error "bad thing to be a operand type: ~S" spec)) - (t - (case (first spec) - (:or - (collect ((results)) - (results :or) - (dolist (item (cdr spec)) - (unless (symbolp item) - (error "bad PRIMITIVE-TYPE name in ~S: ~S" - spec item)) - (let ((alias - (gethash item - *backend-primitive-type-aliases*))) - (if alias - (let ((alias (parse-operand-type alias))) - (unless (eq (car alias) :or) - (error "can't include primitive-type ~ + (cond ((eq spec '*) spec) + ((symbolp spec) + (let ((alias (gethash spec + *backend-primitive-type-aliases*))) + (if alias + (parse-operand-type alias) + `(:or ,spec)))) + ((atom spec) + (error "bad thing to be a operand type: ~S" spec)) + (t + (case (first spec) + (:or + (collect ((results)) + (results :or) + (dolist (item (cdr spec)) + (unless (symbolp item) + (error "bad PRIMITIVE-TYPE name in ~S: ~S" + spec item)) + (let ((alias + (gethash item + *backend-primitive-type-aliases*))) + (if alias + (let ((alias (parse-operand-type alias))) + (unless (eq (car alias) :or) + (error "can't include primitive-type ~ alias ~S in an :OR restriction: ~S" - item spec)) - (dolist (x (cdr alias)) - (results x))) - (results item)))) - (remove-duplicates (results) - :test #'eq - :start 1))) - (:constant - (unless args-p - (error "can't :CONSTANT for a result")) - (unless (= (length spec) 2) - (error "bad :CONSTANT argument type spec: ~S" spec)) - spec) - (t - (error "bad thing to be a operand type: ~S" spec))))))) + item spec)) + (dolist (x (cdr alias)) + (results x))) + (results item)))) + (remove-duplicates (results) + :test #'eq + :start 1))) + (:constant + (unless args-p + (error "can't :CONSTANT for a result")) + (unless (= (length spec) 2) + (error "bad :CONSTANT argument type spec: ~S" spec)) + spec) + (t + (error "bad thing to be a operand type: ~S" spec))))))) (mapcar #'parse-operand-type specs))) ;;; Check the consistency of OP's SC restrictions with the specified @@ -1302,36 +1302,36 @@ (defun check-operand-type-scs (parse op type load-p) (declare (type vop-parse parse) (type operand-parse op)) (let ((ptypes (if (eq type '*) (list t) (rest type))) - (scs (operand-parse-scs op))) + (scs (operand-parse-scs op))) (when scs (multiple-value-bind (costs load-scs) (compute-loading-costs op load-p) - (declare (ignore costs)) - (dolist (ptype ptypes) - (unless (dolist (rep (primitive-type-scs - (meta-primitive-type-or-lose ptype)) - nil) - (when (svref load-scs rep) (return t))) - (error "In the ~A ~:[result~;argument~] to VOP ~S,~@ + (declare (ignore costs)) + (dolist (ptype ptypes) + (unless (dolist (rep (primitive-type-scs + (meta-primitive-type-or-lose ptype)) + nil) + (when (svref load-scs rep) (return t))) + (error "In the ~A ~:[result~;argument~] to VOP ~S,~@ none of the SCs allowed by the operand type ~S can ~ directly be loaded~@ into any of the restriction's SCs:~% ~S~:[~;~@ [* type operand must allow T's SCs.]~]" - (operand-parse-name op) load-p (vop-parse-name parse) - ptype - scs (eq type '*))))) + (operand-parse-name op) load-p (vop-parse-name parse) + ptype + scs (eq type '*))))) (dolist (sc scs) - (unless (or (eq type '*) - (dolist (ptype ptypes nil) - (when (meta-sc-allowed-by-primitive-type - (meta-sc-or-lose sc) - (meta-primitive-type-or-lose ptype)) - (return t)))) - (warn "~:[Result~;Argument~] ~A to VOP ~S~@ + (unless (or (eq type '*) + (dolist (ptype ptypes nil) + (when (meta-sc-allowed-by-primitive-type + (meta-sc-or-lose sc) + (meta-primitive-type-or-lose ptype)) + (return t)))) + (warn "~:[Result~;Argument~] ~A to VOP ~S~@ has SC restriction ~S which is ~ not allowed by the operand type:~% ~S" - load-p (operand-parse-name op) (vop-parse-name parse) - sc type))))) + load-p (operand-parse-name op) (vop-parse-name parse) + sc type))))) (values)) @@ -1339,32 +1339,32 @@ ;;; against the number of defined operands. (defun check-operand-types (parse ops more-op types load-p) (declare (type vop-parse parse) (list ops) - (type (or list (member :unspecified)) types) - (type (or operand-parse null) more-op)) + (type (or list (member :unspecified)) types) + (type (or operand-parse null) more-op)) (unless (eq types :unspecified) (let ((num (+ (length ops) (if more-op 1 0)))) (unless (= (count-if-not (lambda (x) - (and (consp x) - (eq (car x) :constant))) - types) - num) - (error "expected ~W ~:[result~;argument~] type~P: ~S" - num load-p types num))) + (and (consp x) + (eq (car x) :constant))) + types) + num) + (error "expected ~W ~:[result~;argument~] type~P: ~S" + num load-p types num))) (when more-op (let ((mtype (car (last types)))) - (when (and (consp mtype) (eq (first mtype) :constant)) - (error "can't use :CONSTANT on VOP more args"))))) + (when (and (consp mtype) (eq (first mtype) :constant)) + (error "can't use :CONSTANT on VOP more args"))))) (when (vop-parse-translate parse) (let ((types (specify-operand-types types ops more-op))) (mapc (lambda (x y) - (check-operand-type-scs parse x y load-p)) - (if more-op (butlast ops) ops) - (remove-if (lambda (x) - (and (consp x) - (eq (car x) ':constant))) - (if more-op (butlast types) types))))) + (check-operand-type-scs parse x y load-p)) + (if more-op (butlast ops) ops) + (remove-if (lambda (x) + (and (consp x) + (eq (car x) ':constant))) + (if more-op (butlast types) types))))) (values)) @@ -1374,25 +1374,25 @@ (declare (type vop-parse parse)) (setf (vop-parse-operands parse) - (append (vop-parse-args parse) - (if (vop-parse-more-args parse) - (list (vop-parse-more-args parse))) - (vop-parse-results parse) - (if (vop-parse-more-results parse) - (list (vop-parse-more-results parse))) - (vop-parse-temps parse))) + (append (vop-parse-args parse) + (if (vop-parse-more-args parse) + (list (vop-parse-more-args parse))) + (vop-parse-results parse) + (if (vop-parse-more-results parse) + (list (vop-parse-more-results parse))) + (vop-parse-temps parse))) (check-operand-types parse - (vop-parse-args parse) - (vop-parse-more-args parse) - (vop-parse-arg-types parse) - t) + (vop-parse-args parse) + (vop-parse-more-args parse) + (vop-parse-arg-types parse) + t) (check-operand-types parse - (vop-parse-results parse) - (vop-parse-more-results parse) - (vop-parse-result-types parse) - nil) + (vop-parse-results parse) + (vop-parse-more-results parse) + (vop-parse-result-types parse) + nil) (values)) @@ -1406,32 +1406,32 @@ (defun !set-up-fun-translation (parse n-template) (declare (type vop-parse parse)) (mapcar (lambda (name) - `(let ((info (fun-info-or-lose ',name))) - (setf (fun-info-templates info) - (adjoin-template ,n-template (fun-info-templates info))) - ,@(when (vop-parse-conditional-p parse) - '((setf (fun-info-attributes info) - (attributes-union - (ir1-attributes predicate) - (fun-info-attributes info))))))) - (vop-parse-translate parse))) + `(let ((info (fun-info-or-lose ',name))) + (setf (fun-info-templates info) + (adjoin-template ,n-template (fun-info-templates info))) + ,@(when (vop-parse-conditional-p parse) + '((setf (fun-info-attributes info) + (attributes-union + (ir1-attributes predicate) + (fun-info-attributes info))))))) + (vop-parse-translate parse))) ;;; Return a form that can be evaluated to get the TEMPLATE operand type ;;; restriction from the given specification. (defun make-operand-type (type) (cond ((eq type '*) ''*) - ((symbolp type) - ``(:or ,(primitive-type-or-lose ',type))) - (t - (ecase (first type) - (:or - ``(:or ,,@(mapcar (lambda (type) - `(primitive-type-or-lose ',type)) - (rest type)))) - (:constant - ``(:constant ,#'(lambda (x) - (typep x ',(second type))) - ,',(second type))))))) + ((symbolp type) + ``(:or ,(primitive-type-or-lose ',type))) + (t + (ecase (first type) + (:or + ``(:or ,,@(mapcar (lambda (type) + `(primitive-type-or-lose ',type)) + (rest type)))) + (:constant + ``(:constant ,#'(lambda (x) + (typep x ',(second type))) + ,',(second type))))))) (defun specify-operand-types (types ops more-ops) (if (eq types :unspecified) @@ -1444,27 +1444,27 @@ ;;; type until the template has been made. (defun make-vop-info-types (parse) (let* ((more-args (vop-parse-more-args parse)) - (all-args (specify-operand-types (vop-parse-arg-types parse) - (vop-parse-args parse) - more-args)) - (args (if more-args (butlast all-args) all-args)) - (more-arg (when more-args (car (last all-args)))) - (more-results (vop-parse-more-results parse)) - (all-results (specify-operand-types (vop-parse-result-types parse) - (vop-parse-results parse) - more-results)) - (results (if more-results (butlast all-results) all-results)) - (more-result (when more-results (car (last all-results)))) - (conditional (vop-parse-conditional-p parse))) + (all-args (specify-operand-types (vop-parse-arg-types parse) + (vop-parse-args parse) + more-args)) + (args (if more-args (butlast all-args) all-args)) + (more-arg (when more-args (car (last all-args)))) + (more-results (vop-parse-more-results parse)) + (all-results (specify-operand-types (vop-parse-result-types parse) + (vop-parse-results parse) + more-results)) + (results (if more-results (butlast all-results) all-results)) + (more-result (when more-results (car (last all-results)))) + (conditional (vop-parse-conditional-p parse))) `(:type (specifier-type '(function () nil)) :arg-types (list ,@(mapcar #'make-operand-type args)) :more-args-type ,(when more-args (make-operand-type more-arg)) :result-types ,(if conditional - :conditional - `(list ,@(mapcar #'make-operand-type results))) + :conditional + `(list ,@(mapcar #'make-operand-type results))) :more-results-type ,(when more-results - (make-operand-type more-result))))) + (make-operand-type more-result))))) ;;;; setting up VOP-INFO @@ -1483,30 +1483,30 @@ (defmacro inherit-vop-info (slot parse test form) `(if (and ,parse ,test) (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*)) - (error "unknown slot ~S" slot)) - (template-or-lose ',(vop-parse-name ,parse)))) + (error "unknown slot ~S" slot)) + (template-or-lose ',(vop-parse-name ,parse)))) (list ,slot ,form))) ;;; Return a form that creates a VOP-INFO structure which describes VOP. (defun set-up-vop-info (iparse parse) (declare (type vop-parse parse) (type (or vop-parse null) iparse)) (let ((same-operands - (and iparse - (equal (vop-parse-operands parse) - (vop-parse-operands iparse)) - (equal (vop-parse-info-args iparse) - (vop-parse-info-args parse)))) - (variant (vop-parse-variant parse))) + (and iparse + (equal (vop-parse-operands parse) + (vop-parse-operands iparse)) + (equal (vop-parse-info-args iparse) + (vop-parse-info-args parse)))) + (variant (vop-parse-variant parse))) (let ((nvars (length (vop-parse-variant-vars parse)))) (unless (= (length variant) nvars) - (error "expected ~W variant values: ~S" nvars variant))) + (error "expected ~W variant values: ~S" nvars variant))) `(make-vop-info :name ',(vop-parse-name parse) ,@(make-vop-info-types parse) :guard ,(when (vop-parse-guard parse) - `(lambda () ,(vop-parse-guard parse))) + `(lambda () ,(vop-parse-guard parse))) :note ',(vop-parse-note parse) :info-arg-count ,(length (vop-parse-info-args parse)) :ltn-policy ',(vop-parse-ltn-policy parse) @@ -1517,10 +1517,10 @@ ,@(make-costs-and-restrictions parse) ,@(make-emit-function-and-friends parse) ,@(inherit-vop-info :generator-function iparse - (and same-operands - (equal (vop-parse-body parse) (vop-parse-body iparse))) - (unless (eq (vop-parse-body parse) :unspecified) - (make-generator-function parse))) + (and same-operands + (equal (vop-parse-body parse) (vop-parse-body iparse))) + (unless (eq (vop-parse-body parse) :unspecified) + (make-generator-function parse))) :variant (list ,@variant)))) ;;; Define the symbol NAME to be a Virtual OPeration in the compiler. @@ -1641,7 +1641,7 @@ ;;; corresponding Things within the body of the generator. ;;; ;;; :VARIANT-COST Cost -;;; Specifies the cost of this VOP, overriding the cost of any +;;; Specifies the cost of this VOP, overriding the cost of any ;;; inherited generator. ;;; ;;; :NOTE {String | NIL} @@ -1689,11 +1689,11 @@ ;; We implement inheritance by copying the VOP-PARSE structure for ;; the inherited structure. (let* ((inherited-parse (when inherits - (vop-parse-or-lose inherits))) - (parse (if inherits - (copy-vop-parse inherited-parse) - (make-vop-parse))) - (n-res (gensym))) + (vop-parse-or-lose inherits))) + (parse (if inherits + (copy-vop-parse inherited-parse) + (make-vop-parse))) + (n-res (gensym))) (setf (vop-parse-name parse) name) (setf (vop-parse-inherits parse) inherits) @@ -1702,14 +1702,14 @@ `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (gethash ',name *backend-parsed-vops*) - ',parse)) + (setf (gethash ',name *backend-parsed-vops*) + ',parse)) (let ((,n-res ,(set-up-vop-info inherited-parse parse))) - (setf (gethash ',name *backend-template-names*) ,n-res) - (setf (template-type ,n-res) - (specifier-type (template-type-specifier ,n-res))) - ,@(!set-up-fun-translation parse n-res)) + (setf (gethash ',name *backend-template-names*) ,n-res) + (setf (template-type ,n-res) + (specifier-type (template-type-specifier ,n-res))) + ,@(!set-up-fun-translation parse n-res)) ',name))) ;;;; emission macros @@ -1725,23 +1725,23 @@ ;;; then we don't bother to set the tail. (defun make-operand-list (fixed more write-p) (collect ((forms) - (binds)) + (binds)) (let ((n-head nil) - (n-prev nil)) + (n-prev nil)) (dolist (op fixed) - (let ((n-ref (gensym))) - (binds `(,n-ref (reference-tn ,op ,write-p))) - (if n-prev - (forms `(setf (tn-ref-across ,n-prev) ,n-ref)) - (setq n-head n-ref)) - (setq n-prev n-ref))) + (let ((n-ref (gensym))) + (binds `(,n-ref (reference-tn ,op ,write-p))) + (if n-prev + (forms `(setf (tn-ref-across ,n-prev) ,n-ref)) + (setq n-head n-ref)) + (setq n-prev n-ref))) (when more - (let ((n-more (gensym))) - (binds `(,n-more ,more)) - (if n-prev - (forms `(setf (tn-ref-across ,n-prev) ,n-more)) - (setq n-head n-more)))) + (let ((n-more (gensym))) + (binds `(,n-more ,more)) + (if n-prev + (forms `(setf (tn-ref-across ,n-prev) ,n-more)) + (setq n-head n-more)))) (values (forms) (binds) n-head)))) @@ -1751,15 +1751,15 @@ ;;; end of BLOCK. (defmacro emit-template (node block template args results &optional info) (let ((n-first (gensym)) - (n-last (gensym))) + (n-last (gensym))) (once-only ((n-node node) - (n-block block) - (n-template template)) + (n-block block) + (n-template template)) `(multiple-value-bind (,n-first ,n-last) - (funcall (template-emit-function ,n-template) - ,n-node ,n-block ,n-template ,args ,results - ,@(when info `(,info))) - (insert-vop-sequence ,n-first ,n-last ,n-block nil))))) + (funcall (template-emit-function ,n-template) + ,n-node ,n-block ,n-template ,args ,results + ,@(when info `(,info))) + (insert-vop-sequence ,n-first ,n-last ,n-block nil))))) ;;; VOP Name Node Block Arg* Info* Result* ;;; @@ -1777,45 +1777,45 @@ ;;; following the arguments are used for codegen info. (defmacro vop (name node block &rest operands) (let* ((parse (vop-parse-or-lose name)) - (arg-count (length (vop-parse-args parse))) - (result-count (length (vop-parse-results parse))) - (info-count (length (vop-parse-info-args parse))) - (noperands (+ arg-count result-count info-count)) - (n-node (gensym)) - (n-block (gensym)) - (n-template (gensym))) + (arg-count (length (vop-parse-args parse))) + (result-count (length (vop-parse-results parse))) + (info-count (length (vop-parse-info-args parse))) + (noperands (+ arg-count result-count info-count)) + (n-node (gensym)) + (n-block (gensym)) + (n-template (gensym))) (when (or (vop-parse-more-args parse) (vop-parse-more-results parse)) (error "cannot use VOP with variable operand count templates")) (unless (= noperands (length operands)) (error "called with ~W operands, but was expecting ~W" - (length operands) noperands)) + (length operands) noperands)) (multiple-value-bind (acode abinds n-args) - (make-operand-list (subseq operands 0 arg-count) nil nil) + (make-operand-list (subseq operands 0 arg-count) nil nil) (multiple-value-bind (rcode rbinds n-results) - (make-operand-list (subseq operands (+ arg-count info-count)) nil t) - - (collect ((ibinds) - (ivars)) - (dolist (info (subseq operands arg-count (+ arg-count info-count))) - (let ((temp (gensym))) - (ibinds `(,temp ,info)) - (ivars temp))) - - `(let* ((,n-node ,node) - (,n-block ,block) - (,n-template (template-or-lose ',name)) - ,@abinds - ,@(ibinds) - ,@rbinds) - ,@acode - ,@rcode - (emit-template ,n-node ,n-block ,n-template ,n-args - ,n-results - ,@(when (ivars) - `((list ,@(ivars))))) - (values))))))) + (make-operand-list (subseq operands (+ arg-count info-count)) nil t) + + (collect ((ibinds) + (ivars)) + (dolist (info (subseq operands arg-count (+ arg-count info-count))) + (let ((temp (gensym))) + (ibinds `(,temp ,info)) + (ivars temp))) + + `(let* ((,n-node ,node) + (,n-block ,block) + (,n-template (template-or-lose ',name)) + ,@abinds + ,@(ibinds) + ,@rbinds) + ,@acode + ,@rcode + (emit-template ,n-node ,n-block ,n-template ,n-args + ,n-results + ,@(when (ivars) + `((list ,@(ivars))))) + (values))))))) ;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info* ;;; @@ -1835,40 +1835,40 @@ (defmacro vop* (name node block args results &rest info) (declare (type cons args results)) (let* ((parse (vop-parse-or-lose name)) - (arg-count (length (vop-parse-args parse))) - (result-count (length (vop-parse-results parse))) - (info-count (length (vop-parse-info-args parse))) - (fixed-args (butlast args)) - (fixed-results (butlast results)) - (n-node (gensym)) - (n-block (gensym)) - (n-template (gensym))) + (arg-count (length (vop-parse-args parse))) + (result-count (length (vop-parse-results parse))) + (info-count (length (vop-parse-info-args parse))) + (fixed-args (butlast args)) + (fixed-results (butlast results)) + (n-node (gensym)) + (n-block (gensym)) + (n-template (gensym))) (unless (or (vop-parse-more-args parse) - (<= (length fixed-args) arg-count)) + (<= (length fixed-args) arg-count)) (error "too many fixed arguments")) (unless (or (vop-parse-more-results parse) - (<= (length fixed-results) result-count)) + (<= (length fixed-results) result-count)) (error "too many fixed results")) (unless (= (length info) info-count) (error "expected ~W info args" info-count)) (multiple-value-bind (acode abinds n-args) - (make-operand-list fixed-args (car (last args)) nil) + (make-operand-list fixed-args (car (last args)) nil) (multiple-value-bind (rcode rbinds n-results) - (make-operand-list fixed-results (car (last results)) t) - - `(let* ((,n-node ,node) - (,n-block ,block) - (,n-template (template-or-lose ',name)) - ,@abinds - ,@rbinds) - ,@acode - ,@rcode - (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results - ,@(when info - `((list ,@info)))) - (values)))))) + (make-operand-list fixed-results (car (last results)) t) + + `(let* ((,n-node ,node) + (,n-block ,block) + (,n-template (template-or-lose ',name)) + ,@abinds + ,@rbinds) + ,@acode + ,@rcode + (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results + ,@(when info + `((list ,@info)))) + (values)))))) ;;;; miscellaneous macros @@ -1881,43 +1881,43 @@ ;;; error is signalled. (def!macro sc-case (tn &rest forms) (let ((n-sc (gensym)) - (n-tn (gensym))) + (n-tn (gensym))) (collect ((clauses)) (do ((cases forms (rest cases))) - ((null cases) - (clauses `(t (error "unknown SC to SC-CASE for ~S:~% ~S" ,n-tn - (sc-name (tn-sc ,n-tn)))))) - (let ((case (first cases))) - (when (atom case) - (error "illegal SC-CASE clause: ~S" case)) - (let ((head (first case))) - (when (eq head t) - (when (rest cases) - (error "T case is not last in SC-CASE.")) - (clauses `(t nil ,@(rest case))) - (return)) - (clauses `((or ,@(mapcar (lambda (x) - `(eql ,(meta-sc-number-or-lose x) - ,n-sc)) - (if (atom head) (list head) head))) - nil ,@(rest case)))))) + ((null cases) + (clauses `(t (error "unknown SC to SC-CASE for ~S:~% ~S" ,n-tn + (sc-name (tn-sc ,n-tn)))))) + (let ((case (first cases))) + (when (atom case) + (error "illegal SC-CASE clause: ~S" case)) + (let ((head (first case))) + (when (eq head t) + (when (rest cases) + (error "T case is not last in SC-CASE.")) + (clauses `(t nil ,@(rest case))) + (return)) + (clauses `((or ,@(mapcar (lambda (x) + `(eql ,(meta-sc-number-or-lose x) + ,n-sc)) + (if (atom head) (list head) head))) + nil ,@(rest case)))))) `(let* ((,n-tn ,tn) - (,n-sc (sc-number (tn-sc ,n-tn)))) - (cond ,@(clauses)))))) + (,n-sc (sc-number (tn-sc ,n-tn)))) + (cond ,@(clauses)))))) ;;; Return true if TNs SC is any of the named SCs, false otherwise. (defmacro sc-is (tn &rest scs) (once-only ((n-sc `(sc-number (tn-sc ,tn)))) `(or ,@(mapcar (lambda (x) - `(eql ,n-sc ,(meta-sc-number-or-lose x))) - scs)))) + `(eql ,n-sc ,(meta-sc-number-or-lose x))) + scs)))) ;;; Iterate over the IR2 blocks in component, in emission order. (defmacro do-ir2-blocks ((block-var component &optional result) - &body forms) + &body forms) `(do ((,block-var (block-info (component-head ,component)) - (ir2-block-next ,block-var))) + (ir2-block-next ,block-var))) ((null ,block-var) ,result) ,@forms)) @@ -1926,48 +1926,48 @@ ;;; containing the location. (defmacro do-live-tns ((tn-var live block &optional result) &body body) (let ((n-conf (gensym)) - (n-bod (gensym)) - (i (gensym)) - (ltns (gensym))) + (n-bod (gensym)) + (i (gensym)) + (ltns (gensym))) (once-only ((n-live live) - (n-block block)) + (n-block block)) `(block nil - (flet ((,n-bod (,tn-var) ,@body)) - ;; Do component-live TNs. - (dolist (,tn-var (ir2-component-component-tns - (component-info - (block-component - (ir2-block-block ,n-block))))) - (,n-bod ,tn-var)) - - (let ((,ltns (ir2-block-local-tns ,n-block))) - ;; Do TNs always-live in this block and live :MORE TNs. - (do ((,n-conf (ir2-block-global-tns ,n-block) - (global-conflicts-next-blockwise ,n-conf))) - ((null ,n-conf)) - (when (or (eq (global-conflicts-kind ,n-conf) :live) - (let ((,i (global-conflicts-number ,n-conf))) - (and (eq (svref ,ltns ,i) :more) - (not (zerop (sbit ,n-live ,i)))))) - (,n-bod (global-conflicts-tn ,n-conf)))) - ;; Do TNs locally live in the designated live set. - (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result) - (unless (zerop (sbit ,n-live ,i)) - (let ((,tn-var (svref ,ltns ,i))) - (when (and ,tn-var (not (eq ,tn-var :more))) - (,n-bod ,tn-var))))))))))) + (flet ((,n-bod (,tn-var) ,@body)) + ;; Do component-live TNs. + (dolist (,tn-var (ir2-component-component-tns + (component-info + (block-component + (ir2-block-block ,n-block))))) + (,n-bod ,tn-var)) + + (let ((,ltns (ir2-block-local-tns ,n-block))) + ;; Do TNs always-live in this block and live :MORE TNs. + (do ((,n-conf (ir2-block-global-tns ,n-block) + (global-conflicts-next-blockwise ,n-conf))) + ((null ,n-conf)) + (when (or (eq (global-conflicts-kind ,n-conf) :live) + (let ((,i (global-conflicts-number ,n-conf))) + (and (eq (svref ,ltns ,i) :more) + (not (zerop (sbit ,n-live ,i)))))) + (,n-bod (global-conflicts-tn ,n-conf)))) + ;; Do TNs locally live in the designated live set. + (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result) + (unless (zerop (sbit ,n-live ,i)) + (let ((,tn-var (svref ,ltns ,i))) + (when (and ,tn-var (not (eq ,tn-var :more))) + (,n-bod ,tn-var))))))))))) ;;; Iterate over all the IR2 blocks in PHYSENV, in emit order. (defmacro do-physenv-ir2-blocks ((block-var physenv &optional result) - &body body) + &body body) (once-only ((n-physenv physenv)) (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv)))) (once-only ((n-tail `(block-info - (component-tail - (block-component ,n-first))))) - `(do ((,block-var (block-info ,n-first) - (ir2-block-next ,block-var))) - ((or (eq ,block-var ,n-tail) - (not (eq (ir2-block-physenv ,block-var) ,n-physenv))) - ,result) - ,@body))))) + (component-tail + (block-component ,n-first))))) + `(do ((,block-var (block-info ,n-first) + (ir2-block-next ,block-var))) + ((or (eq ,block-var ,n-tail) + (not (eq (ir2-block-physenv ,block-var) ,n-physenv))) + ,result) + ,@body))))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 4439b79..6f5eb69 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -22,24 +22,24 @@ ;;; "Lead-in" Control TRANsfer [to some node] (def!struct (ctran - (:make-load-form-fun ignore-it) - (:constructor make-ctran)) + (:make-load-form-fun ignore-it) + (:constructor make-ctran)) ;; an indication of the way that this continuation is currently used ;; ;; :UNUSED - ;; A continuation for which all control-related slots have the - ;; default values. A continuation is unused during IR1 conversion - ;; until it is assigned a block, and may be also be temporarily - ;; unused during later manipulations of IR1. In a consistent - ;; state there should never be any mention of :UNUSED - ;; continuations. NEXT can have a non-null value if the next node - ;; has already been determined. + ;; A continuation for which all control-related slots have the + ;; default values. A continuation is unused during IR1 conversion + ;; until it is assigned a block, and may be also be temporarily + ;; unused during later manipulations of IR1. In a consistent + ;; state there should never be any mention of :UNUSED + ;; continuations. NEXT can have a non-null value if the next node + ;; has already been determined. ;; ;; :BLOCK-START - ;; The continuation that is the START of BLOCK. + ;; The continuation that is the START of BLOCK. ;; ;; :INSIDE-BLOCK - ;; A continuation that is the NEXT of some node in BLOCK. + ;; A continuation that is the NEXT of some node in BLOCK. (kind :unused :type (member :unused :inside-block :block-start)) ;; A NODE which is to be evaluated next. Null only temporary. (next nil :type (or node null)) @@ -58,8 +58,8 @@ ;;; Linear VARiable. Multiple-value (possibly of unknown number) ;;; temporal storage. (def!struct (lvar - (:make-load-form-fun ignore-it) - (:constructor make-lvar (&optional dest))) + (:make-load-form-fun ignore-it) + (:constructor make-lvar (&optional dest))) ;; The node which receives this value. NIL only temporarily. (dest nil :type (or node null)) ;; cached type of this lvar's value. If NIL, then this must be @@ -86,7 +86,7 @@ (format stream "~D" (cont-num x)))) (def!struct (node (:constructor nil) - (:copier nil)) + (:copier nil)) ;; unique ID for debugging #!+sb-show (id (new-object-id) :read-only t) ;; True if this node needs to be optimized. This is set to true @@ -137,9 +137,9 @@ (tail-p nil :type boolean)) (def!struct (valued-node (:conc-name node-) - (:include node) - (:constructor nil) - (:copier nil)) + (:include node) + (:constructor nil) + (:copier nil)) ;; the bottom-up derived type for this node. (derived-type *wild-type* :type ctype) ;; Lvar, receiving the values, produced by this node. May be NIL if @@ -175,8 +175,8 @@ ;;; FIXME: Tweak so that definitions of e.g. BLOCK-DELETE-P is ;;; findable by grep for 'def.*block-delete-p'. (macrolet ((frob (slot) - `(defmacro ,(symbolicate "BLOCK-" slot) (block) - `(block-attributep (block-flags ,block) ,',slot)))) + `(defmacro ,(symbolicate "BLOCK-" slot) (block) + `(block-attributep (block-flags ,block) ,',slot)))) (frob reoptimize) (frob flush-p) (frob type-check) @@ -192,10 +192,10 @@ ;;; numbering in the debug-info (though that is relative to the start ;;; of the function.) (def!struct (cblock (:include sset-element) - (:constructor make-block (start)) - (:constructor make-block-key) - (:conc-name block-) - (:predicate block-p)) + (:constructor make-block (start)) + (:constructor make-block-key) + (:conc-name block-) + (:predicate block-p)) ;; a list of all the blocks that are predecessors/successors of this ;; block. In well-formed IR1, most blocks will have one successor. ;; The only exceptions are: @@ -218,8 +218,8 @@ (prev nil :type (or null cblock)) ;; This block's attributes: see above. (flags (block-attributes reoptimize flush-p type-check type-asserted - test-modified) - :type attributes) + test-modified) + :type attributes) ;; in constraint propagation: list of LAMBDA-VARs killed in this block ;; in copy propagation: list of killed TNs (kill nil) @@ -228,7 +228,7 @@ (in nil) (out nil) ;; Set of all blocks that dominate this block. NIL is interpreted - ;; as "all blocks in component". + ;; as "all blocks in component". (dominators nil :type (or null sset)) ;; the LOOP that this block belongs to (loop nil :type (or null cloop)) @@ -237,9 +237,9 @@ ;; the component this block is in, or NIL temporarily during IR1 ;; conversion and in deleted blocks (component (progn - (aver-live-component *current-component*) - *current-component*) - :type (or component null)) + (aver-live-component *current-component*) + *current-component*) + :type (or component null)) ;; a flag used by various graph-walking code to determine whether ;; this block has been processed already or what. We make this ;; initially NIL so that FIND-INITIAL-DFO doesn't have to scan the @@ -260,7 +260,7 @@ ;;; different BLOCK-INFO annotation structures so that code ;;; (specifically control analysis) can be shared. (def!struct (block-annotation (:constructor nil) - (:copier nil)) + (:copier nil)) ;; The IR1 block that this block is in the INFO for. (block (missing-arg) :type cblock) ;; the next and previous block in emission order (not DFO). This @@ -282,8 +282,8 @@ ;;; structures to be reclaimed after the compilation of each ;;; component. (def!struct (component (:copier nil) - (:constructor - make-component + (:constructor + make-component (head tail &aux (last-block tail) @@ -425,7 +425,7 @@ (lambda-has-external-references-p clambda))) (defun component-toplevelish-p (component) (member (component-kind component) - '(:toplevel :complex-toplevel))) + '(:toplevel :complex-toplevel))) ;;; A CLEANUP structure represents some dynamic binding action. Blocks ;;; are annotated with the current CLEANUP so that dynamic bindings @@ -442,8 +442,8 @@ (def!struct (cleanup (:copier nil)) ;; the kind of thing that has to be cleaned up (kind (missing-arg) - :type (member :special-bind :catch :unwind-protect - :block :tagbody :dynamic-extent)) + :type (member :special-bind :catch :unwind-protect + :block :tagbody :dynamic-extent)) ;; the node that messes things up. This is the last node in the ;; non-messed-up environment. Null only temporarily. This could be ;; deleted due to unreachability. @@ -541,12 +541,12 @@ ;;; continuation, although it is accessed by searching in the ;;; PHYSENV-NLX-INFO. (def!struct (nlx-info - (:constructor make-nlx-info (cleanup - exit - &aux + (:constructor make-nlx-info (cleanup + exit + &aux (block (first (block-succ (node-block exit)))))) - (:make-load-form-fun ignore-it)) + (:make-load-form-fun ignore-it)) ;; the cleanup associated with this exit. In a catch or ;; unwind-protect, this is the :CATCH or :UNWIND-PROTECT cleanup, ;; and not the cleanup for the escape block. The CLEANUP-KIND of @@ -586,7 +586,7 @@ ;;; allows us to easily substitute one for the other without actually ;;; hacking the flow graph. (def!struct (leaf (:make-load-form-fun ignore-it) - (:constructor nil)) + (:constructor nil)) ;; unique ID for debugging #!+sb-show (id (new-object-id) :read-only t) ;; (For public access to this slot, use LEAF-SOURCE-NAME.) @@ -610,8 +610,8 @@ ;; See also the LEAF-DEBUG-NAME function and the ;; FUNCTIONAL-%DEBUG-NAME slot. (%source-name (missing-arg) - :type (or symbol (and cons (satisfies legal-fun-name-p))) - :read-only t) + :type (or symbol (and cons (satisfies legal-fun-name-p))) + :read-only t) ;; the type which values of this leaf must have (type *universal-type* :type ctype) ;; where the TYPE information came from: @@ -638,7 +638,7 @@ ;;; KLUDGE: wants CLOS.. (defun leaf-has-source-name-p (leaf) (not (eq (leaf-%source-name leaf) - '.anonymous.))) + '.anonymous.))) (defun leaf-source-name (leaf) (aver (leaf-has-source-name-p leaf)) (leaf-%source-name leaf)) @@ -669,7 +669,7 @@ ;;; The BASIC-VAR structure represents information common to all ;;; variables which don't correspond to known local functions. (def!struct (basic-var (:include leaf) - (:constructor nil)) + (:constructor nil)) ;; Lists of the set nodes for this variable. (sets () :type list)) @@ -678,7 +678,7 @@ (def!struct (global-var (:include basic-var)) ;; kind of variable described (kind (missing-arg) - :type (member :special :global-function :global))) + :type (member :special :global-function :global))) (defprinter (global-var :identity t) %source-name #!+sb-show id @@ -692,8 +692,8 @@ ;;; an inline proclamation) we copy the structure so that former ;;; INLINEP values are preserved. (def!struct (defined-fun (:include global-var - (where-from :defined) - (kind :global-function))) + (where-from :defined) + (kind :global-function))) ;; The values of INLINEP and INLINE-EXPANSION initialized from the ;; global environment. (inlinep nil :type inlinep) @@ -715,14 +715,14 @@ ;;; We don't normally manipulate function types for defined functions, ;;; but if someone wants to know, an approximation is there. (def!struct (functional (:include leaf - (%source-name '.anonymous.) - (where-from :defined) - (type (specifier-type 'function)))) + (%source-name '.anonymous.) + (where-from :defined) + (type (specifier-type 'function)))) ;; (For public access to this slot, use LEAF-DEBUG-NAME.) ;; ;; the name of FUNCTIONAL for debugging purposes, or NIL if we ;; should just let the SOURCE-NAME fall through - ;; + ;; ;; Unlike the SOURCE-NAME slot, this slot's value should never ;; affect ordinary code behavior, only debugging/diagnostic behavior. ;; @@ -751,70 +751,70 @@ ;; %SOURCE-NAME=FOO (or maybe .ANONYMOUS.?) ;; %DEBUG-NAME=(MACRO-FUNCTION FOO) (%debug-name nil - :type (or null (not (satisfies legal-fun-name-p))) - :read-only t) + :type (or null (not (satisfies legal-fun-name-p))) + :read-only t) ;; some information about how this function is used. These values ;; are meaningful: ;; ;; NIL - ;; an ordinary function, callable using local call + ;; an ordinary function, callable using local call ;; ;; :LET - ;; a lambda that is used in only one local call, and has in - ;; effect been substituted directly inline. The return node is - ;; deleted, and the result is computed with the actual result - ;; lvar for the call. + ;; a lambda that is used in only one local call, and has in + ;; effect been substituted directly inline. The return node is + ;; deleted, and the result is computed with the actual result + ;; lvar for the call. ;; ;; :MV-LET - ;; Similar to :LET (as per FUNCTIONAL-LETLIKE-P), but the call + ;; Similar to :LET (as per FUNCTIONAL-LETLIKE-P), but the call ;; is an MV-CALL. ;; ;; :ASSIGNMENT - ;; similar to a LET (as per FUNCTIONAL-SOMEWHAT-LETLIKE-P), but + ;; similar to a LET (as per FUNCTIONAL-SOMEWHAT-LETLIKE-P), but ;; can have other than one call as long as there is at most ;; one non-tail call. ;; ;; :OPTIONAL - ;; a lambda that is an entry point for an OPTIONAL-DISPATCH. - ;; Similar to NIL, but requires greater caution, since local call - ;; analysis may create new references to this function. Also, the - ;; function cannot be deleted even if it has *no* references. The - ;; OPTIONAL-DISPATCH is in the LAMDBA-OPTIONAL-DISPATCH. + ;; a lambda that is an entry point for an OPTIONAL-DISPATCH. + ;; Similar to NIL, but requires greater caution, since local call + ;; analysis may create new references to this function. Also, the + ;; function cannot be deleted even if it has *no* references. The + ;; OPTIONAL-DISPATCH is in the LAMDBA-OPTIONAL-DISPATCH. ;; ;; :EXTERNAL - ;; an external entry point lambda. The function it is an entry - ;; for is in the ENTRY-FUN slot. + ;; an external entry point lambda. The function it is an entry + ;; for is in the ENTRY-FUN slot. ;; ;; :TOPLEVEL - ;; a top level lambda, holding a compiled top level form. - ;; Compiled very much like NIL, but provides an indication of - ;; top level context. A :TOPLEVEL lambda should have *no* - ;; references. Its ENTRY-FUN is a self-pointer. + ;; a top level lambda, holding a compiled top level form. + ;; Compiled very much like NIL, but provides an indication of + ;; top level context. A :TOPLEVEL lambda should have *no* + ;; references. Its ENTRY-FUN is a self-pointer. ;; ;; :TOPLEVEL-XEP - ;; After a component is compiled, we clobber any top level code - ;; references to its non-closure XEPs with dummy FUNCTIONAL - ;; structures having this kind. This prevents the retained - ;; top level code from holding onto the IR for the code it - ;; references. + ;; After a component is compiled, we clobber any top level code + ;; references to its non-closure XEPs with dummy FUNCTIONAL + ;; structures having this kind. This prevents the retained + ;; top level code from holding onto the IR for the code it + ;; references. ;; ;; :ESCAPE ;; :CLEANUP - ;; special functions used internally by CATCH and UNWIND-PROTECT. - ;; These are pretty much like a normal function (NIL), but are - ;; treated specially by local call analysis and stuff. Neither - ;; kind should ever be given an XEP even though they appear as - ;; args to funny functions. An :ESCAPE function is never actually - ;; called, and thus doesn't need to have code generated for it. + ;; special functions used internally by CATCH and UNWIND-PROTECT. + ;; These are pretty much like a normal function (NIL), but are + ;; treated specially by local call analysis and stuff. Neither + ;; kind should ever be given an XEP even though they appear as + ;; args to funny functions. An :ESCAPE function is never actually + ;; called, and thus doesn't need to have code generated for it. ;; ;; :DELETED - ;; This function has been found to be uncallable, and has been - ;; marked for deletion. + ;; This function has been found to be uncallable, and has been + ;; marked for deletion. ;; ;; :ZOMBIE ;; Effectless [MV-]LET; has no BIND node. (kind nil :type (member nil :optional :deleted :external :toplevel - :escape :cleanup :let :mv-let :assignment + :escape :cleanup :let :mv-let :assignment :zombie :toplevel-xep)) ;; Is this a function that some external entity (e.g. the fasl dumper) ;; refers to, so that even when it appears to have no references, it @@ -864,7 +864,7 @@ ;;; it returns one value or multiple values) (defun functional-letlike-p (functional) (member (functional-kind functional) - '(:let :mv-let))) + '(:let :mv-let))) ;;; Is FUNCTIONAL sorta LET-converted? (where even an :ASSIGNMENT counts) ;;; @@ -894,10 +894,10 @@ ;;; optional, keyword and rest arguments are handled by transforming ;;; into simpler stuff. (def!struct (clambda (:include functional) - (:conc-name lambda-) - (:predicate lambda-p) - (:constructor make-lambda) - (:copier copy-lambda)) + (:conc-name lambda-) + (:predicate lambda-p) + (:constructor make-lambda) + (:copier copy-lambda)) ;; list of LAMBDA-VAR descriptors for arguments (vars nil :type list :read-only t) ;; If this function was ever a :OPTIONAL function (an entry-point @@ -1041,8 +1041,8 @@ ;; the kind of argument being described. Required args only have arg ;; info structures if they are special. (kind (missing-arg) - :type (member :required :optional :keyword :rest - :more-context :more-count)) + :type (member :required :optional :keyword :rest + :more-context :more-count)) ;; If true, this is the VAR for SUPPLIED-P variable of a keyword or ;; optional arg. This is true for keywords with non-constant ;; defaults even when there is no user-specified supplied-p var. @@ -1120,12 +1120,12 @@ ;;; initially (and forever) NIL, since REFs don't receive any values ;;; and don't have any IR1 optimizer. (def!struct (ref (:include valued-node (reoptimize nil)) - (:constructor make-ref - (leaf - &aux (leaf-type (leaf-type leaf)) - (derived-type - (make-single-value-type leaf-type)))) - (:copier nil)) + (:constructor make-ref + (leaf + &aux (leaf-type (leaf-type leaf)) + (derived-type + (make-single-value-type leaf-type)))) + (:copier nil)) ;; The leaf referenced. (leaf nil :type leaf)) (defprinter (ref :identity t) @@ -1134,10 +1134,10 @@ ;;; Naturally, the IF node always appears at the end of a block. (def!struct (cif (:include node) - (:conc-name if-) - (:predicate if-p) - (:constructor make-if) - (:copier copy-if)) + (:conc-name if-) + (:predicate if-p) + (:constructor make-if) + (:copier copy-if)) ;; LVAR for the predicate (test (missing-arg) :type lvar) ;; the blocks that we execute next in true and false case, @@ -1150,12 +1150,12 @@ alternative) (def!struct (cset (:include valued-node - (derived-type (make-single-value-type + (derived-type (make-single-value-type *universal-type*))) - (:conc-name set-) - (:predicate set-p) - (:constructor make-set) - (:copier copy-set)) + (:conc-name set-) + (:predicate set-p) + (:constructor make-set) + (:copier copy-set)) ;; descriptor for the variable set (var (missing-arg) :type basic-var) ;; LVAR for the value form @@ -1169,8 +1169,8 @@ ;;; node appears at the end of its block and the body of the called ;;; function appears as the successor; the NODE-LVAR is null. (def!struct (basic-combination (:include valued-node) - (:constructor nil) - (:copier nil)) + (:constructor nil) + (:copier nil)) ;; LVAR for the function (fun (missing-arg) :type lvar) ;; list of LVARs for the args. In a local call, an argument lvar may @@ -1196,23 +1196,23 @@ ;;; including FUNCALL. This is distinct from BASIC-COMBINATION so that ;;; an MV-COMBINATION isn't COMBINATION-P. (def!struct (combination (:include basic-combination) - (:constructor make-combination (fun)) - (:copier nil))) + (:constructor make-combination (fun)) + (:copier nil))) (defprinter (combination :identity t) #!+sb-show id (fun :prin1 (lvar-uses fun)) (args :prin1 (mapcar (lambda (x) - (if x - (lvar-uses x) - "")) - args))) + (if x + (lvar-uses x) + "")) + args))) ;;; An MV-COMBINATION is to MULTIPLE-VALUE-CALL as a COMBINATION is to ;;; FUNCALL. This is used to implement all the multiple-value ;;; receiving forms. (def!struct (mv-combination (:include basic-combination) - (:constructor make-mv-combination (fun)) - (:copier nil))) + (:constructor make-mv-combination (fun)) + (:copier nil))) (defprinter (mv-combination) (fun :prin1 (lvar-uses fun)) (args :prin1 (mapcar #'lvar-uses args))) @@ -1220,7 +1220,7 @@ ;;; The BIND node marks the beginning of a lambda body and represents ;;; the creation and initialization of the variables. (def!struct (bind (:include node) - (:copier nil)) + (:copier nil)) ;; the lambda we are binding variables for. Null when we are ;; creating the LAMBDA during IR1 translation. (lambda nil :type (or clambda null))) @@ -1232,10 +1232,10 @@ ;;; is also where we stick information used for TAIL-SET type ;;; inference. (def!struct (creturn (:include node) - (:conc-name return-) - (:predicate return-p) - (:constructor make-return) - (:copier copy-return)) + (:conc-name return-) + (:predicate return-p) + (:constructor make-return) + (:copier copy-return)) ;; the lambda we are returning from. Null temporarily during ;; ir1tran. (lambda nil :type (or clambda null)) @@ -1254,7 +1254,7 @@ ;;; TYPE-TO-CHECK is performed and then the VALUE is declared to be of ;;; type ASSERTED-TYPE. (def!struct (cast (:include valued-node) - (:constructor %make-cast)) + (:constructor %make-cast)) (asserted-type (missing-arg) :type ctype) (type-to-check (missing-arg) :type ctype) ;; an indication of what we have proven about how this type @@ -1286,7 +1286,7 @@ ;;; lexical exit. It is the mess-up node for the corresponding :ENTRY ;;; cleanup. (def!struct (entry (:include node) - (:copier nil)) + (:copier nil)) ;; All of the EXIT nodes for potential non-local exits to this point. (exits nil :type list) ;; The cleanup for this entry. NULL only temporarily. @@ -1302,7 +1302,7 @@ ;;; lvar is the exit node's LVAR; physenv analysis also makes it the ;;; lvar of %NLX-ENTRY call. (def!struct (exit (:include valued-node) - (:copier nil)) + (:copier nil)) ;; the ENTRY node that this is an exit for. If null, this is a ;; degenerate exit. A degenerate exit is used to "fill" an empty ;; block (which isn't allowed in IR1.) In a degenerate exit, Value @@ -1320,11 +1320,11 @@ ;;;; miscellaneous IR1 structures (def!struct (undefined-warning - #-no-ansi-print-object - (:print-object (lambda (x s) - (print-unreadable-object (x s :type t) - (prin1 (undefined-warning-name x) s)))) - (:copier nil)) + #-no-ansi-print-object + (:print-object (lambda (x s) + (print-unreadable-object (x s :type t) + (prin1 (undefined-warning-name x) s)))) + (:copier nil)) ;; the name of the unknown thing (name nil :type (or symbol list)) ;; the kind of reference to NAME @@ -1339,13 +1339,13 @@ ;;; a helper for the POLICY macro, defined late here so that the ;;; various type tests can be inlined (declaim (ftype (function ((or list lexenv node functional)) list) - %coerce-to-policy)) + %coerce-to-policy)) (defun %coerce-to-policy (thing) (let ((result (etypecase thing - (list thing) - (lexenv (lexenv-policy thing)) - (node (lexenv-policy (node-lexenv thing))) - (functional (lexenv-policy (functional-lexenv thing)))))) + (list thing) + (lexenv (lexenv-policy thing)) + (node (lexenv-policy (node-lexenv thing))) + (functional (lexenv-policy (functional-lexenv thing)))))) ;; Test the first element of the list as a rudimentary sanity ;; that it really does look like a valid policy. (aver (or (null result) (policy-quality-name-p (caar result)))) @@ -1356,4 +1356,4 @@ #!-sb-fluid (declaim (freeze-type node leaf lexenv ctran lvar cblock component cleanup - physenv tail-set nlx-info)) + physenv tail-set nlx-info)) diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index b4c5a67..a911dbd 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -42,33 +42,33 @@ (defun offset-conflicts-in-sb (tn sb offset) (declare (type tn tn) (type finite-sb sb) (type index offset)) (let ((confs (tn-global-conflicts tn)) - (kind (tn-kind tn))) + (kind (tn-kind tn))) (cond ((eq kind :component) (let ((loc-live (svref (finite-sb-always-live sb) offset))) - (dotimes (i (ir2-block-count *component-being-compiled*) nil) - (when (/= (sbit loc-live i) 0) - (return t))))) + (dotimes (i (ir2-block-count *component-being-compiled*) nil) + (when (/= (sbit loc-live i) 0) + (return t))))) (confs (let ((loc-confs (svref (finite-sb-conflicts sb) offset)) - (loc-live (svref (finite-sb-always-live sb) offset))) - (do ((conf confs (global-conflicts-next-tnwise conf))) - ((null conf) - nil) - (let* ((block (global-conflicts-block conf)) - (num (ir2-block-number block))) - (if (eq (global-conflicts-kind conf) :live) - (when (/= (sbit loc-live num) 0) - (return t)) - (when (/= (sbit (svref loc-confs num) - (global-conflicts-number conf)) - 0) - (return t))))))) + (loc-live (svref (finite-sb-always-live sb) offset))) + (do ((conf confs (global-conflicts-next-tnwise conf))) + ((null conf) + nil) + (let* ((block (global-conflicts-block conf)) + (num (ir2-block-number block))) + (if (eq (global-conflicts-kind conf) :live) + (when (/= (sbit loc-live num) 0) + (return t)) + (when (/= (sbit (svref loc-confs num) + (global-conflicts-number conf)) + 0) + (return t))))))) (t (/= (sbit (svref (svref (finite-sb-conflicts sb) offset) - (ir2-block-number (tn-local tn))) - (tn-local-number tn)) - 0))))) + (ir2-block-number (tn-local tn))) + (tn-local-number tn)) + 0))))) ;;; Return true if TN has a conflict in SC at the specified offset. (defun conflicts-in-sc (tn sc offset) @@ -76,7 +76,7 @@ (let ((sb (sc-sb sc))) (dotimes (i (sc-element-size sc) nil) (when (offset-conflicts-in-sb tn sb (+ offset i)) - (return t))))) + (return t))))) ;;; Add TN's conflicts into the conflicts for the location at OFFSET ;;; in SC. We iterate over each location in TN, adding to the @@ -95,41 +95,41 @@ (defun add-location-conflicts (tn sc offset optimize) (declare (type tn tn) (type sc sc) (type index offset)) (let ((confs (tn-global-conflicts tn)) - (sb (sc-sb sc)) - (kind (tn-kind tn))) + (sb (sc-sb sc)) + (kind (tn-kind tn))) (dotimes (i (sc-element-size sc)) (declare (type index i)) (let* ((this-offset (+ offset i)) - (loc-confs (svref (finite-sb-conflicts sb) this-offset)) - (loc-live (svref (finite-sb-always-live sb) this-offset))) - (cond - ((eq kind :component) - (dotimes (num (ir2-block-count *component-being-compiled*)) - (declare (type index num)) - (setf (sbit loc-live num) 1) - (set-bit-vector (svref loc-confs num)))) - (confs - (do ((conf confs (global-conflicts-next-tnwise conf))) - ((null conf)) - (let* ((block (global-conflicts-block conf)) - (num (ir2-block-number block)) - (local-confs (svref loc-confs num))) - (declare (type local-tn-bit-vector local-confs)) - (setf (sbit loc-live num) 1) - (if (eq (global-conflicts-kind conf) :live) - (set-bit-vector local-confs) - (bit-ior local-confs (global-conflicts-conflicts conf) t))))) - (t - (let ((num (ir2-block-number (tn-local tn)))) - (setf (sbit loc-live num) 1) - (bit-ior (the local-tn-bit-vector (svref loc-confs num)) - (tn-local-conflicts tn) t)))) - ;; Calculating ALWAYS-LIVE-COUNT is moderately expensive, and - ;; currently the information isn't used unless (> SPEED - ;; COMPILE-SPEED). - (when optimize - (setf (svref (finite-sb-always-live-count sb) this-offset) - (find-location-usage sb this-offset)))))) + (loc-confs (svref (finite-sb-conflicts sb) this-offset)) + (loc-live (svref (finite-sb-always-live sb) this-offset))) + (cond + ((eq kind :component) + (dotimes (num (ir2-block-count *component-being-compiled*)) + (declare (type index num)) + (setf (sbit loc-live num) 1) + (set-bit-vector (svref loc-confs num)))) + (confs + (do ((conf confs (global-conflicts-next-tnwise conf))) + ((null conf)) + (let* ((block (global-conflicts-block conf)) + (num (ir2-block-number block)) + (local-confs (svref loc-confs num))) + (declare (type local-tn-bit-vector local-confs)) + (setf (sbit loc-live num) 1) + (if (eq (global-conflicts-kind conf) :live) + (set-bit-vector local-confs) + (bit-ior local-confs (global-conflicts-conflicts conf) t))))) + (t + (let ((num (ir2-block-number (tn-local tn)))) + (setf (sbit loc-live num) 1) + (bit-ior (the local-tn-bit-vector (svref loc-confs num)) + (tn-local-conflicts tn) t)))) + ;; Calculating ALWAYS-LIVE-COUNT is moderately expensive, and + ;; currently the information isn't used unless (> SPEED + ;; COMPILE-SPEED). + (when optimize + (setf (svref (finite-sb-always-live-count sb) this-offset) + (find-location-usage sb this-offset)))))) (values)) ;; A rought measure of how much a given OFFSET in SB is currently @@ -146,7 +146,7 @@ (defun ir2-block-count (component) (declare (type component component)) (do ((2block (block-info (block-next (component-head component))) - (ir2-block-next 2block))) + (ir2-block-next 2block))) ((null 2block) (error "What? No ir2 blocks have a non-nil number?")) (when (ir2-block-number 2block) @@ -159,53 +159,53 @@ (let ((nblocks (ir2-block-count component))) (dolist (sb *backend-sb-list*) (unless (eq (sb-kind sb) :non-packed) - (let* ((conflicts (finite-sb-conflicts sb)) - (always-live (finite-sb-always-live sb)) - (always-live-count (finite-sb-always-live-count sb)) - (max-locs (length conflicts)) - (last-count (finite-sb-last-block-count sb))) - (unless (zerop max-locs) - (let ((current-size (length (the simple-vector - (svref conflicts 0))))) - (cond - ((> nblocks current-size) - (let ((new-size (max nblocks (* current-size 2)))) - (declare (type index new-size)) - (dotimes (i max-locs) - (declare (type index i)) - (let ((new-vec (make-array new-size))) - (let ((old (svref conflicts i))) - (declare (simple-vector old)) - (dotimes (j current-size) - (declare (type index j)) - (setf (svref new-vec j) - (clear-bit-vector (svref old j))))) - - (do ((j current-size (1+ j))) - ((= j new-size)) - (declare (type index j)) - (setf (svref new-vec j) - (make-array local-tn-limit :element-type 'bit - :initial-element 0))) - (setf (svref conflicts i) new-vec)) - (setf (svref always-live i) - (make-array new-size :element-type 'bit - :initial-element 0)) - (setf (svref always-live-count i) 0)))) - (t - (dotimes (i (finite-sb-current-size sb)) - (declare (type index i)) - (let ((conf (svref conflicts i))) - (declare (simple-vector conf)) - (dotimes (j last-count) - (declare (type index j)) - (clear-bit-vector (svref conf j)))) - (clear-bit-vector (svref always-live i)) - (setf (svref always-live-count i) 0)))))) - - (setf (finite-sb-last-block-count sb) nblocks) - (setf (finite-sb-current-size sb) (sb-size sb)) - (setf (finite-sb-last-offset sb) 0)))))) + (let* ((conflicts (finite-sb-conflicts sb)) + (always-live (finite-sb-always-live sb)) + (always-live-count (finite-sb-always-live-count sb)) + (max-locs (length conflicts)) + (last-count (finite-sb-last-block-count sb))) + (unless (zerop max-locs) + (let ((current-size (length (the simple-vector + (svref conflicts 0))))) + (cond + ((> nblocks current-size) + (let ((new-size (max nblocks (* current-size 2)))) + (declare (type index new-size)) + (dotimes (i max-locs) + (declare (type index i)) + (let ((new-vec (make-array new-size))) + (let ((old (svref conflicts i))) + (declare (simple-vector old)) + (dotimes (j current-size) + (declare (type index j)) + (setf (svref new-vec j) + (clear-bit-vector (svref old j))))) + + (do ((j current-size (1+ j))) + ((= j new-size)) + (declare (type index j)) + (setf (svref new-vec j) + (make-array local-tn-limit :element-type 'bit + :initial-element 0))) + (setf (svref conflicts i) new-vec)) + (setf (svref always-live i) + (make-array new-size :element-type 'bit + :initial-element 0)) + (setf (svref always-live-count i) 0)))) + (t + (dotimes (i (finite-sb-current-size sb)) + (declare (type index i)) + (let ((conf (svref conflicts i))) + (declare (simple-vector conf)) + (dotimes (j last-count) + (declare (type index j)) + (clear-bit-vector (svref conf j)))) + (clear-bit-vector (svref always-live i)) + (setf (svref always-live-count i) 0)))))) + + (setf (finite-sb-last-block-count sb) nblocks) + (setf (finite-sb-current-size sb) (sb-size sb)) + (setf (finite-sb-last-offset sb) 0)))))) ;;; Expand the :UNBOUNDED SB backing SC by either the initial size or ;;; the SC element size, whichever is larger. If NEEDED-SIZE is @@ -213,56 +213,56 @@ (defun grow-sc (sc &optional (needed-size 0)) (declare (type sc sc) (type index needed-size)) (let* ((sb (sc-sb sc)) - (size (finite-sb-current-size sb)) - (align-mask (1- (sc-alignment sc))) - (inc (max (sb-size sb) - (+ (sc-element-size sc) - (- (logandc2 (+ size align-mask) align-mask) - size)) - (- needed-size size))) - (new-size (+ size inc)) - (conflicts (finite-sb-conflicts sb)) - (block-size (if (zerop (length conflicts)) - (ir2-block-count *component-being-compiled*) - (length (the simple-vector (svref conflicts 0)))))) + (size (finite-sb-current-size sb)) + (align-mask (1- (sc-alignment sc))) + (inc (max (sb-size sb) + (+ (sc-element-size sc) + (- (logandc2 (+ size align-mask) align-mask) + size)) + (- needed-size size))) + (new-size (+ size inc)) + (conflicts (finite-sb-conflicts sb)) + (block-size (if (zerop (length conflicts)) + (ir2-block-count *component-being-compiled*) + (length (the simple-vector (svref conflicts 0)))))) (declare (type index inc new-size)) (aver (eq (sb-kind sb) :unbounded)) (when (> new-size (length conflicts)) (let ((new-conf (make-array new-size))) - (replace new-conf conflicts) - (do ((i size (1+ i))) - ((= i new-size)) - (declare (type index i)) - (let ((loc-confs (make-array block-size))) - (dotimes (j block-size) - (setf (svref loc-confs j) - (make-array local-tn-limit - :initial-element 0 - :element-type 'bit))) - (setf (svref new-conf i) loc-confs))) - (setf (finite-sb-conflicts sb) new-conf)) + (replace new-conf conflicts) + (do ((i size (1+ i))) + ((= i new-size)) + (declare (type index i)) + (let ((loc-confs (make-array block-size))) + (dotimes (j block-size) + (setf (svref loc-confs j) + (make-array local-tn-limit + :initial-element 0 + :element-type 'bit))) + (setf (svref new-conf i) loc-confs))) + (setf (finite-sb-conflicts sb) new-conf)) (let ((new-live (make-array new-size))) - (replace new-live (finite-sb-always-live sb)) - (do ((i size (1+ i))) - ((= i new-size)) - (setf (svref new-live i) - (make-array block-size - :initial-element 0 - :element-type 'bit))) - (setf (finite-sb-always-live sb) new-live)) + (replace new-live (finite-sb-always-live sb)) + (do ((i size (1+ i))) + ((= i new-size)) + (setf (svref new-live i) + (make-array block-size + :initial-element 0 + :element-type 'bit))) + (setf (finite-sb-always-live sb) new-live)) (let ((new-live-count (make-array new-size))) - (declare (optimize speed)) ;; FILL deftransform - (replace new-live-count (finite-sb-always-live-count sb)) - (fill new-live-count 0 :start size) - (setf (finite-sb-always-live-count sb) new-live-count)) - + (declare (optimize speed)) ;; FILL deftransform + (replace new-live-count (finite-sb-always-live-count sb)) + (fill new-live-count 0 :start size) + (setf (finite-sb-always-live-count sb) new-live-count)) + (let ((new-tns (make-array new-size :initial-element nil))) - (replace new-tns (finite-sb-live-tns sb)) - (fill (finite-sb-live-tns sb) nil) - (setf (finite-sb-live-tns sb) new-tns))) + (replace new-tns (finite-sb-live-tns sb)) + (fill (finite-sb-live-tns sb) nil) + (setf (finite-sb-live-tns sb) new-tns))) (setf (finite-sb-current-size sb) new-size)) (values)) @@ -274,28 +274,28 @@ ;;; defined to move from SRC to DEST. (defun no-load-fun-error (src dest) (let* ((src-sc (tn-sc src)) - (src-name (sc-name src-sc)) - (dest-sc (tn-sc dest)) - (dest-name (sc-name dest-sc))) + (src-name (sc-name src-sc)) + (dest-sc (tn-sc dest)) + (dest-name (sc-name dest-sc))) (cond ((eq (sb-kind (sc-sb src-sc)) :non-packed) - (unless (member src-sc (sc-constant-scs dest-sc)) - (error "loading from an invalid constant SC?~@ + (unless (member src-sc (sc-constant-scs dest-sc)) + (error "loading from an invalid constant SC?~@ VM definition inconsistent, try recompiling.")) - (error "no load function defined to load SC ~S ~ + (error "no load function defined to load SC ~S ~ from its constant SC ~S" - dest-name src-name)) - ((member src-sc (sc-alternate-scs dest-sc)) - (error "no load function defined to load SC ~S from its ~ + dest-name src-name)) + ((member src-sc (sc-alternate-scs dest-sc)) + (error "no load function defined to load SC ~S from its ~ alternate SC ~S" - dest-name src-name)) - ((member dest-sc (sc-alternate-scs src-sc)) - (error "no load function defined to save SC ~S in its ~ + dest-name src-name)) + ((member dest-sc (sc-alternate-scs src-sc)) + (error "no load function defined to save SC ~S in its ~ alternate SC ~S" - src-name dest-name)) - (t - ;; FIXME: "VM definition is inconsistent" shouldn't be a - ;; possibility in SBCL. - (error "loading to/from SCs that aren't alternates?~@ + src-name dest-name)) + (t + ;; FIXME: "VM definition is inconsistent" shouldn't be a + ;; possibility in SBCL. + (error "loading to/from SCs that aren't alternates?~@ VM definition is inconsistent, try recompiling."))))) ;;; Called when we failed to pack TN. If RESTRICTED is true, then we @@ -303,35 +303,35 @@ (defun failed-to-pack-error (tn restricted) (declare (type tn tn)) (let* ((sc (tn-sc tn)) - (scs (cons sc (sc-alternate-scs sc)))) + (scs (cons sc (sc-alternate-scs sc)))) (cond (restricted (error "failed to pack restricted TN ~S in its SC ~S" - tn (sc-name sc))) + tn (sc-name sc))) (t (aver (not (find :unbounded scs - :key (lambda (x) (sb-kind (sc-sb x)))))) + :key (lambda (x) (sb-kind (sc-sb x)))))) (let ((ptype (tn-primitive-type tn))) - (cond - (ptype - (aver (member (sc-number sc) (primitive-type-scs ptype))) - (error "SC ~S doesn't have any :UNBOUNDED alternate SCs, but is~@ + (cond + (ptype + (aver (member (sc-number sc) (primitive-type-scs ptype))) + (error "SC ~S doesn't have any :UNBOUNDED alternate SCs, but is~@ a SC for primitive-type ~S." - (sc-name sc) (primitive-type-name ptype))) - (t - (error "SC ~S doesn't have any :UNBOUNDED alternate SCs." - (sc-name sc))))))))) + (sc-name sc) (primitive-type-name ptype))) + (t + (error "SC ~S doesn't have any :UNBOUNDED alternate SCs." + (sc-name sc))))))))) ;;; Return a list of format arguments describing how TN is used in ;;; OP's VOP. (defun describe-tn-use (loc tn op) (let* ((vop (tn-ref-vop op)) - (args (vop-args vop)) - (results (vop-results vop)) - (name (with-output-to-string (stream) - (print-tn-guts tn stream))) - (2comp (component-info *component-being-compiled*)) - temp) + (args (vop-args vop)) + (results (vop-results vop)) + (name (with-output-to-string (stream) + (print-tn-guts tn stream))) + (2comp (component-info *component-being-compiled*)) + temp) (cond ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-tn)) `("~2D: ~A (~:R argument)" ,loc ,name ,(1+ temp))) @@ -340,15 +340,15 @@ ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-load-tn)) `("~2D: ~A (~:R argument load TN)" ,loc ,name ,(1+ temp))) ((setq temp (position-in #'tn-ref-across tn results :key - #'tn-ref-load-tn)) + #'tn-ref-load-tn)) `("~2D: ~A (~:R result load TN)" ,loc ,name ,(1+ temp))) ((setq temp (position-in #'tn-ref-across tn (vop-temps vop) - :key #'tn-ref-tn)) + :key #'tn-ref-tn)) `("~2D: ~A (temporary ~A)" ,loc ,name - ,(operand-parse-name (elt (vop-parse-temps - (vop-parse-or-lose - (vop-info-name (vop-info vop)))) - temp)))) + ,(operand-parse-name (elt (vop-parse-temps + (vop-parse-or-lose + (vop-info-name (vop-info vop)))) + temp)))) ((eq (tn-kind tn) :component) `("~2D: ~A (component live)" ,loc ,name)) ((position-in #'tn-next tn (ir2-component-wired-tns 2comp)) @@ -363,31 +363,31 @@ (defun failed-to-pack-load-tn-error (scs op) (declare (list scs) (type tn-ref op)) (collect ((used) - (unused)) + (unused)) (dolist (sc scs) (let* ((sb (sc-sb sc)) - (confs (finite-sb-live-tns sb))) - (aver (eq (sb-kind sb) :finite)) - (dolist (el (sc-locations sc)) - (declare (type index el)) - (let ((conf (load-tn-conflicts-in-sc op sc el t))) - (if conf - (used (describe-tn-use el conf op)) - (do ((i el (1+ i)) - (end (+ el (sc-element-size sc)))) - ((= i end) - (unused el)) - (declare (type index i end)) - (let ((victim (svref confs i))) - (when victim - (used (describe-tn-use el victim op)) - (return t))))))))) + (confs (finite-sb-live-tns sb))) + (aver (eq (sb-kind sb) :finite)) + (dolist (el (sc-locations sc)) + (declare (type index el)) + (let ((conf (load-tn-conflicts-in-sc op sc el t))) + (if conf + (used (describe-tn-use el conf op)) + (do ((i el (1+ i)) + (end (+ el (sc-element-size sc)))) + ((= i end) + (unused el)) + (declare (type index i end)) + (let ((victim (svref confs i))) + (when victim + (used (describe-tn-use el victim op)) + (return t))))))))) (multiple-value-bind (arg-p n more-p costs load-scs incon) - (get-operand-info op) + (get-operand-info op) (declare (ignore costs load-scs)) - (aver (not more-p)) - (error "unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~ + (aver (not more-p)) + (error "unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~ for the ~:R ~:[result~;argument~] to~@ the ~S VOP,~@ ~:[since all SC elements are in use:~:{~%~@?~}~%~;~ @@ -395,20 +395,20 @@ ~:[~;~@ Current cost info inconsistent with that in effect at compile ~ time. Recompile.~%Compilation order may be incorrect.~]" - (mapcar #'sc-name scs) - n arg-p - (vop-info-name (vop-info (tn-ref-vop op))) - (unused) (used) - incon)))) + (mapcar #'sc-name scs) + n arg-p + (vop-info-name (vop-info (tn-ref-vop op))) + (unused) (used) + incon)))) ;;; This is called when none of the SCs that we can load OP into are ;;; allowed by OP's primitive-type. (defun no-load-scs-allowed-by-primitive-type-error (ref) (declare (type tn-ref ref)) (let* ((tn (tn-ref-tn ref)) - (ptype (tn-primitive-type tn))) + (ptype (tn-primitive-type tn))) (multiple-value-bind (arg-p pos more-p costs load-scs incon) - (get-operand-info ref) + (get-operand-info ref) (declare (ignore costs)) (aver (not more-p)) (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~ @@ -418,11 +418,11 @@ ~:[~;~@ Current cost info inconsistent with that in effect at compile ~ time. Recompile.~%Compilation order may be incorrect.~]" - tn pos arg-p - (template-name (vop-info (tn-ref-vop ref))) - (primitive-type-name ptype) - (mapcar #'sc-name (listify-restrictions load-scs)) - incon)))) + tn pos arg-p + (template-name (vop-info (tn-ref-vop ref))) + (primitive-type-name ptype) + (mapcar #'sc-name (listify-restrictions load-scs)) + incon)))) ;;;; register saving @@ -441,40 +441,40 @@ (declare (type tn tn)) (let ((res (make-tn 0 :save nil nil))) (dolist (alt (sc-alternate-scs (tn-sc tn)) - (error "no unbounded alternate for SC ~S" - (sc-name (tn-sc tn)))) + (error "no unbounded alternate for SC ~S" + (sc-name (tn-sc tn)))) (when (eq (sb-kind (sc-sb alt)) :unbounded) - (setf (tn-save-tn tn) res) - (setf (tn-save-tn res) tn) - (setf (tn-sc res) alt) - (pack-tn res t nil) - (return res))))) + (setf (tn-save-tn tn) res) + (setf (tn-save-tn res) tn) + (setf (tn-sc res) alt) + (pack-tn res t nil) + (return res))))) ;;; Find the load function for moving from SRC to DEST and emit a ;;; MOVE-OPERAND VOP with that function as its info arg. (defun emit-operand-load (node block src dest before) (declare (type node node) (type ir2-block block) - (type tn src dest) (type (or vop null) before)) + (type tn src dest) (type (or vop null) before)) (emit-load-template node block - (template-or-lose 'move-operand) - src dest - (list (or (svref (sc-move-funs (tn-sc dest)) - (sc-number (tn-sc src))) - (no-load-fun-error src dest))) - before) + (template-or-lose 'move-operand) + src dest + (list (or (svref (sc-move-funs (tn-sc dest)) + (sc-number (tn-sc src))) + (no-load-fun-error src dest))) + before) (values)) ;;; Find the preceding use of the VOP NAME in the emit order, starting ;;; with VOP. We must find the VOP in the same IR1 block. (defun reverse-find-vop (name vop) (do* ((block (vop-block vop) (ir2-block-prev block)) - (last vop (ir2-block-last-vop block))) + (last vop (ir2-block-last-vop block))) (nil) (aver (eq (ir2-block-block block) (ir2-block-block (vop-block vop)))) (do ((current last (vop-prev current))) - ((null current)) + ((null current)) (when (eq (vop-info-name (vop-info current)) name) - (return-from reverse-find-vop current))))) + (return-from reverse-find-vop current))))) ;;; For TNs that have other than one writer, we save the TN before ;;; each call. If a local call (MOVE-ARGS is :LOCAL-CALL), then we @@ -485,18 +485,18 @@ ;;; which the values are known to be good. (defun save-complex-writer-tn (tn vop) (let ((save (or (tn-save-tn tn) - (pack-save-tn tn))) - (node (vop-node vop)) - (block (vop-block vop)) - (next (vop-next vop))) + (pack-save-tn tn))) + (node (vop-node vop)) + (block (vop-block vop)) + (next (vop-next vop))) (when (eq (tn-kind save) :specified-save) (setf (tn-kind save) :save)) (aver (eq (tn-kind save) :save)) (emit-operand-load node block tn save - (if (eq (vop-info-move-args (vop-info vop)) - :local-call) - (reverse-find-vop 'allocate-frame vop) - vop)) + (if (eq (vop-info-move-args (vop-info vop)) + :local-call) + (reverse-find-vop 'allocate-frame vop) + vop)) (emit-operand-load node block save tn next))) ;;; Return a VOP after which is an OK place to save the value of TN. @@ -515,17 +515,17 @@ (res nil)) ((null write) (when (and res - (do ((read (tn-reads tn) (tn-ref-next read))) - ((not read) t) - (when (eq (vop-info-move-args - (vop-info - (tn-ref-vop read))) - :local-call) - (return nil)))) - (tn-ref-vop res))) + (do ((read (tn-reads tn) (tn-ref-next read))) + ((not read) t) + (when (eq (vop-info-move-args + (vop-info + (tn-ref-vop read))) + :local-call) + (return nil)))) + (tn-ref-vop res))) (unless (eq (vop-info-name (vop-info (tn-ref-vop write))) - 'move-operand) + 'move-operand) (when res (return nil)) (setq res write)))) @@ -534,13 +534,13 @@ (defun save-single-writer-tn (tn) (declare (type tn tn)) (let* ((old-save (tn-save-tn tn)) - (save (or old-save (pack-save-tn tn))) - (writer (find-single-writer tn))) + (save (or old-save (pack-save-tn tn))) + (writer (find-single-writer tn))) (when (and writer - (or (not old-save) - (eq (tn-kind old-save) :specified-save))) + (or (not old-save) + (eq (tn-kind old-save) :specified-save))) (emit-operand-load (vop-node writer) (vop-block writer) - tn save (vop-next writer)) + tn save (vop-next writer)) (setf (tn-kind save) :save-once) t))) @@ -558,11 +558,11 @@ (declare (type tn tn) (type vop vop)) (let ((save (tn-save-tn tn))) (cond ((and save (eq (tn-kind save) :save-once)) - (restore-single-writer-tn tn vop)) - ((save-single-writer-tn tn) - (restore-single-writer-tn tn vop)) - (t - (save-complex-writer-tn tn vop)))) + (restore-single-writer-tn tn vop)) + ((save-single-writer-tn tn) + (restore-single-writer-tn tn vop)) + (t + (save-complex-writer-tn tn vop)))) (values)) ;;; Scan over the VOPs in BLOCK, emiting saving code for TNs noted in @@ -573,9 +573,9 @@ ((null vop)) (when (eq (vop-info-save-p (vop-info vop)) t) (do-live-tns (tn (vop-save-set vop) block) - (when (and (sc-save-p (tn-sc tn)) - (not (eq (tn-kind tn) :component))) - (basic-save-tn tn vop))))) + (when (and (sc-save-p (tn-sc tn)) + (not (eq (tn-kind tn) :component))) + (basic-save-tn tn vop))))) (values)) @@ -593,8 +593,8 @@ (aver (member (tn-kind save) '(:save :save-once))) (unless (eq (tn-kind save) :save-once) (or (save-single-writer-tn tn) - (emit-operand-load (vop-node context) (vop-block context) - tn save before)))) + (emit-operand-load (vop-node context) (vop-block context) + tn save before)))) (values)) ;;; Load the TN from its save location, allocating one if necessary. @@ -604,7 +604,7 @@ (declare (type tn tn) (type (or vop null) before) (type vop context)) (let ((save (or (tn-save-tn tn) (pack-save-tn tn)))) (emit-operand-load (vop-node context) (vop-block context) - save tn before)) + save tn before)) (values)) (eval-when (:compile-toplevel :execute) @@ -612,10 +612,10 @@ ;;; Do stuff to note a read of TN, for OPTIMIZED-EMIT-SAVES-BLOCK. (defmacro save-note-read (tn) `(let* ((tn ,tn) - (num (tn-number tn))) + (num (tn-number tn))) (when (and (sc-save-p (tn-sc tn)) - (zerop (sbit restores num)) - (not (eq (tn-kind tn) :component))) + (zerop (sbit restores num)) + (not (eq (tn-kind tn) :component))) (setf (sbit restores num) 1) (push tn restores-list)))) @@ -651,90 +651,90 @@ (defun optimized-emit-saves-block (block saves restores) (declare (type ir2-block block) (type simple-bit-vector saves restores)) (let ((1block (ir2-block-block block)) - (saves-list ()) - (restores-list ()) - (skipping nil)) + (saves-list ()) + (restores-list ()) + (skipping nil)) (declare (list saves-list restores-list)) (clear-bit-vector saves) (clear-bit-vector restores) (do-live-tns (tn (ir2-block-live-in block) block) (when (and (sc-save-p (tn-sc tn)) - (not (eq (tn-kind tn) :component))) - (let ((num (tn-number tn))) - (setf (sbit restores num) 1) - (push tn restores-list)))) + (not (eq (tn-kind tn) :component))) + (let ((num (tn-number tn))) + (setf (sbit restores num) 1) + (push tn restores-list)))) (do ((block block (ir2-block-prev block)) - (prev nil block)) - ((not (eq (ir2-block-block block) 1block)) - (aver (not skipping)) - (dolist (save saves-list) - (let ((start (ir2-block-start-vop prev))) - (save-if-necessary save start start))) - prev) + (prev nil block)) + ((not (eq (ir2-block-block block) 1block)) + (aver (not skipping)) + (dolist (save saves-list) + (let ((start (ir2-block-start-vop prev))) + (save-if-necessary save start start))) + prev) (do ((vop (ir2-block-last-vop block) (vop-prev vop))) - ((null vop)) - (let ((info (vop-info vop))) - (case (vop-info-name info) - (allocate-frame - (aver skipping) - (setq skipping nil)) - (note-environment-start - (aver (not skipping)) - (dolist (save saves-list) - (save-if-necessary save (vop-next vop) vop)) - (return-from optimized-emit-saves-block block))) - - (unless skipping - (do ((write (vop-results vop) (tn-ref-across write))) - ((null write)) - (let* ((tn (tn-ref-tn write)) - (num (tn-number tn))) - (unless (zerop (sbit restores num)) - (setf (sbit restores num) 0) - (setq restores-list - (delete tn restores-list :test #'eq))) - (unless (zerop (sbit saves num)) - (setf (sbit saves num) 0) - (save-if-necessary tn (vop-next vop) vop) - (setq saves-list - (delete tn saves-list :test #'eq)))))) - - (macrolet (;; Do stuff to note a read of TN, for - ;; OPTIMIZED-EMIT-SAVES-BLOCK. - (save-note-read (tn) - `(let* ((tn ,tn) - (num (tn-number tn))) - (when (and (sc-save-p (tn-sc tn)) - (zerop (sbit restores num)) - (not (eq (tn-kind tn) :component))) - (setf (sbit restores num) 1) - (push tn restores-list))))) - - (case (vop-info-save-p info) - ((t) - (dolist (tn restores-list) - (restore-tn tn (vop-next vop) vop) - (let ((num (tn-number tn))) - (when (zerop (sbit saves num)) - (push tn saves-list) - (setf (sbit saves num) 1)))) - (setq restores-list nil) - (clear-bit-vector restores)) - (:compute-only - (cond ((policy (vop-node vop) (= speed 3)) - (do-live-tns (tn (vop-save-set vop) block) - (when (zerop (sbit restores (tn-number tn))) - (note-spilled-tn tn vop)))) - (t - (do-live-tns (tn (vop-save-set vop) block) - (save-note-read tn)))))) - - (if (eq (vop-info-move-args info) :local-call) - (setq skipping t) - (do ((read (vop-args vop) (tn-ref-across read))) - ((null read)) - (save-note-read (tn-ref-tn read)))))))))) + ((null vop)) + (let ((info (vop-info vop))) + (case (vop-info-name info) + (allocate-frame + (aver skipping) + (setq skipping nil)) + (note-environment-start + (aver (not skipping)) + (dolist (save saves-list) + (save-if-necessary save (vop-next vop) vop)) + (return-from optimized-emit-saves-block block))) + + (unless skipping + (do ((write (vop-results vop) (tn-ref-across write))) + ((null write)) + (let* ((tn (tn-ref-tn write)) + (num (tn-number tn))) + (unless (zerop (sbit restores num)) + (setf (sbit restores num) 0) + (setq restores-list + (delete tn restores-list :test #'eq))) + (unless (zerop (sbit saves num)) + (setf (sbit saves num) 0) + (save-if-necessary tn (vop-next vop) vop) + (setq saves-list + (delete tn saves-list :test #'eq)))))) + + (macrolet (;; Do stuff to note a read of TN, for + ;; OPTIMIZED-EMIT-SAVES-BLOCK. + (save-note-read (tn) + `(let* ((tn ,tn) + (num (tn-number tn))) + (when (and (sc-save-p (tn-sc tn)) + (zerop (sbit restores num)) + (not (eq (tn-kind tn) :component))) + (setf (sbit restores num) 1) + (push tn restores-list))))) + + (case (vop-info-save-p info) + ((t) + (dolist (tn restores-list) + (restore-tn tn (vop-next vop) vop) + (let ((num (tn-number tn))) + (when (zerop (sbit saves num)) + (push tn saves-list) + (setf (sbit saves num) 1)))) + (setq restores-list nil) + (clear-bit-vector restores)) + (:compute-only + (cond ((policy (vop-node vop) (= speed 3)) + (do-live-tns (tn (vop-save-set vop) block) + (when (zerop (sbit restores (tn-number tn))) + (note-spilled-tn tn vop)))) + (t + (do-live-tns (tn (vop-save-set vop) block) + (save-note-read tn)))))) + + (if (eq (vop-info-move-args info) :local-call) + (setq skipping t) + (do ((read (vop-args vop) (tn-ref-across read))) + ((null read)) + (save-note-read (tn-ref-tn read)))))))))) ;;; This is like EMIT-SAVES, only different. We avoid redundant saving ;;; within the block, and don't restore values that aren't used before @@ -744,18 +744,18 @@ (defun optimized-emit-saves (component) (declare (type component component)) (let* ((gtn-count (1+ (ir2-component-global-tn-counter - (component-info component)))) - (saves (make-array gtn-count :element-type 'bit)) - (restores (make-array gtn-count :element-type 'bit)) - (block (ir2-block-prev (block-info (component-tail component)))) - (head (block-info (component-head component)))) + (component-info component)))) + (saves (make-array gtn-count :element-type 'bit)) + (restores (make-array gtn-count :element-type 'bit)) + (block (ir2-block-prev (block-info (component-tail component)))) + (head (block-info (component-head component)))) (loop (when (eq block head) (return)) (when (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop) nil) - (when (eq (vop-info-save-p (vop-info vop)) t) - (return t))) - (setq block (optimized-emit-saves-block block saves restores))) + ((null vop) nil) + (when (eq (vop-info-save-p (vop-info vop)) t) + (return t))) + (setq block (optimized-emit-saves-block block saves restores))) (setq block (ir2-block-prev block))))) ;;; Iterate over the normal TNs, finding the cost of packing on the @@ -765,56 +765,56 @@ (defun assign-tn-costs (component) (do-ir2-blocks (block component) (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop)) + ((null vop)) (when (eq (vop-info-save-p (vop-info vop)) t) - (do-live-tns (tn (vop-save-set vop) block) - (decf (tn-cost tn) *backend-register-save-penalty*))))) + (do-live-tns (tn (vop-save-set vop) block) + (decf (tn-cost tn) *backend-register-save-penalty*))))) (do ((tn (ir2-component-normal-tns (component-info component)) - (tn-next tn))) + (tn-next tn))) ((null tn)) (let ((cost (tn-cost tn))) (declare (fixnum cost)) (do ((ref (tn-reads tn) (tn-ref-next ref))) - ((null ref)) - (incf cost)) + ((null ref)) + (incf cost)) (do ((ref (tn-writes tn) (tn-ref-next ref))) - ((null ref)) - (incf cost)) + ((null ref)) + (incf cost)) (setf (tn-cost tn) cost)))) ;;; Iterate over the normal TNs, storing the depth of the deepest loop ;;; that the TN is used in TN-LOOP-DEPTH. (defun assign-tn-depths (component) - (when *loop-analyze* + (when *loop-analyze* (do-ir2-blocks (block component) (do ((vop (ir2-block-start-vop block) - (vop-next vop))) - ((null vop)) - (flet ((find-all-tns (head-fun) - (collect ((tns)) - (do ((ref (funcall head-fun vop) (tn-ref-across ref))) - ((null ref)) - (tns (tn-ref-tn ref))) - (tns)))) - (dolist (tn (nconc (find-all-tns #'vop-args) - (find-all-tns #'vop-results) - (find-all-tns #'vop-temps) - ;; What does "references in this VOP - ;; mean"? Probably something that isn't - ;; useful in this context, since these - ;; TN-REFs are linked with TN-REF-NEXT - ;; instead of TN-REF-ACROSS. --JES - ;; 2004-09-11 - ;; (find-all-tns #'vop-refs) - )) - (setf (tn-loop-depth tn) - (max (tn-loop-depth tn) - (let* ((ir1-block (ir2-block-block (vop-block vop))) - (loop (block-loop ir1-block))) - (if loop - (loop-depth loop) - 0)))))))))) + (vop-next vop))) + ((null vop)) + (flet ((find-all-tns (head-fun) + (collect ((tns)) + (do ((ref (funcall head-fun vop) (tn-ref-across ref))) + ((null ref)) + (tns (tn-ref-tn ref))) + (tns)))) + (dolist (tn (nconc (find-all-tns #'vop-args) + (find-all-tns #'vop-results) + (find-all-tns #'vop-temps) + ;; What does "references in this VOP + ;; mean"? Probably something that isn't + ;; useful in this context, since these + ;; TN-REFs are linked with TN-REF-NEXT + ;; instead of TN-REF-ACROSS. --JES + ;; 2004-09-11 + ;; (find-all-tns #'vop-refs) + )) + (setf (tn-loop-depth tn) + (max (tn-loop-depth tn) + (let* ((ir1-block (ir2-block-block (vop-block vop))) + (loop (block-loop ir1-block))) + (if loop + (loop-depth loop) + 0)))))))))) ;;;; load TN packing @@ -840,13 +840,13 @@ (do-live-tns (tn (ir2-block-live-in block) block) (let* ((sc (tn-sc tn)) - (sb (sc-sb sc))) + (sb (sc-sb sc))) (when (eq (sb-kind sb) :finite) - (do ((offset (tn-offset tn) (1+ offset)) - (end (+ (tn-offset tn) (sc-element-size sc)))) - ((= offset end)) - (declare (type index offset end)) - (setf (svref (finite-sb-live-tns sb) offset) tn))))) + (do ((offset (tn-offset tn) (1+ offset)) + (end (+ (tn-offset tn) (sc-element-size sc)))) + ((= offset end)) + (declare (type index offset end)) + (setf (svref (finite-sb-live-tns sb) offset) tn))))) (setq *live-block* block) (setq *live-vop* (ir2-block-last-vop block)) @@ -866,44 +866,44 @@ (do ((current *live-vop* (vop-prev current))) ((eq current vop) (do ((res (vop-results vop) (tn-ref-across res))) - ((null res)) - (let* ((tn (tn-ref-tn res)) - (sc (tn-sc tn)) - (sb (sc-sb sc))) - (when (eq (sb-kind sb) :finite) - (do ((offset (tn-offset tn) (1+ offset)) - (end (+ (tn-offset tn) (sc-element-size sc)))) - ((= offset end)) - (declare (type index offset end)) - (setf (svref (finite-sb-live-tns sb) offset) nil)))))) + ((null res)) + (let* ((tn (tn-ref-tn res)) + (sc (tn-sc tn)) + (sb (sc-sb sc))) + (when (eq (sb-kind sb) :finite) + (do ((offset (tn-offset tn) (1+ offset)) + (end (+ (tn-offset tn) (sc-element-size sc)))) + ((= offset end)) + (declare (type index offset end)) + (setf (svref (finite-sb-live-tns sb) offset) nil)))))) (do ((ref (vop-refs current) (tn-ref-next-ref ref))) - ((null ref)) + ((null ref)) (let ((ltn (tn-ref-load-tn ref))) - (when ltn - (let* ((sc (tn-sc ltn)) - (sb (sc-sb sc))) - (when (eq (sb-kind sb) :finite) - (let ((tns (finite-sb-live-tns sb))) - (do ((offset (tn-offset ltn) (1+ offset)) - (end (+ (tn-offset ltn) (sc-element-size sc)))) - ((= offset end)) - (declare (type index offset end)) - (aver (null (svref tns offset))))))))) + (when ltn + (let* ((sc (tn-sc ltn)) + (sb (sc-sb sc))) + (when (eq (sb-kind sb) :finite) + (let ((tns (finite-sb-live-tns sb))) + (do ((offset (tn-offset ltn) (1+ offset)) + (end (+ (tn-offset ltn) (sc-element-size sc)))) + ((= offset end)) + (declare (type index offset end)) + (aver (null (svref tns offset))))))))) (let* ((tn (tn-ref-tn ref)) - (sc (tn-sc tn)) - (sb (sc-sb sc))) - (when (eq (sb-kind sb) :finite) - (let ((tns (finite-sb-live-tns sb))) - (do ((offset (tn-offset tn) (1+ offset)) - (end (+ (tn-offset tn) (sc-element-size sc)))) - ((= offset end)) - (declare (type index offset end)) - (if (tn-ref-write-p ref) - (setf (svref tns offset) nil) - (let ((old (svref tns offset))) - (aver (or (null old) (eq old tn))) - (setf (svref tns offset) tn))))))))) + (sc (tn-sc tn)) + (sb (sc-sb sc))) + (when (eq (sb-kind sb) :finite) + (let ((tns (finite-sb-live-tns sb))) + (do ((offset (tn-offset tn) (1+ offset)) + (end (+ (tn-offset tn) (sc-element-size sc)))) + ((= offset end)) + (declare (type index offset end)) + (if (tn-ref-write-p ref) + (setf (svref tns offset) nil) + (let ((old (svref tns offset))) + (aver (or (null old) (eq old tn))) + (setf (svref tns offset) tn))))))))) (setq *live-vop* vop) (values)) @@ -938,36 +938,36 @@ (aver (eq (sb-kind sb) :finite)) (let ((vop (tn-ref-vop op))) (labels ((tn-overlaps (tn) - (let ((sc (tn-sc tn)) - (tn-offset (tn-offset tn))) - (when (and (eq (sc-sb sc) sb) - (<= tn-offset offset) - (< offset - (the index - (+ tn-offset (sc-element-size sc))))) - tn))) - (same (ref) - (let ((tn (tn-ref-tn ref)) - (ltn (tn-ref-load-tn ref))) - (or (tn-overlaps tn) - (and ltn (tn-overlaps ltn))))) - (is-op (ops) - (do ((ops ops (tn-ref-across ops))) - ((null ops) nil) - (let ((found (same ops))) - (when (and found (not (eq ops op))) - (return found))))) - (is-ref (refs end) - (do ((refs refs (tn-ref-next-ref refs))) - ((eq refs end) nil) - (let ((found (same refs))) - (when found (return found)))))) + (let ((sc (tn-sc tn)) + (tn-offset (tn-offset tn))) + (when (and (eq (sc-sb sc) sb) + (<= tn-offset offset) + (< offset + (the index + (+ tn-offset (sc-element-size sc))))) + tn))) + (same (ref) + (let ((tn (tn-ref-tn ref)) + (ltn (tn-ref-load-tn ref))) + (or (tn-overlaps tn) + (and ltn (tn-overlaps ltn))))) + (is-op (ops) + (do ((ops ops (tn-ref-across ops))) + ((null ops) nil) + (let ((found (same ops))) + (when (and found (not (eq ops op))) + (return found))))) + (is-ref (refs end) + (do ((refs refs (tn-ref-next-ref refs))) + ((eq refs end) nil) + (let ((found (same refs))) + (when found (return found)))))) (declare (inline is-op is-ref tn-overlaps)) (if (tn-ref-write-p op) - (or (is-op (vop-results vop)) - (is-ref (vop-refs vop) op)) - (or (is-op (vop-args vop)) - (is-ref (tn-ref-next-ref op) nil)))))) + (or (is-op (vop-results vop)) + (is-ref (vop-refs vop) op)) + (or (is-op (vop-args vop)) + (is-ref (tn-ref-next-ref op) nil)))))) ;;; Iterate over all the elements in the SB that would be allocated by ;;; allocating a TN in SC at Offset, checking for conflict with @@ -979,16 +979,16 @@ ;;; We return a conflicting TN, or :OVERFLOW if the TN won't fit. (defun load-tn-conflicts-in-sc (op sc offset ignore-live) (let* ((sb (sc-sb sc)) - (size (finite-sb-current-size sb))) + (size (finite-sb-current-size sb))) (do ((i offset (1+ i)) - (end (+ offset (sc-element-size sc)))) - ((= i end) nil) + (end (+ offset (sc-element-size sc)))) + ((= i end) nil) (declare (type index i end)) (let ((res (or (when (>= i size) :overflow) - (and (not ignore-live) - (svref (finite-sb-live-tns sb) i)) - (load-tn-offset-conflicts-in-sb op sb i)))) - (when res (return res)))))) + (and (not ignore-live) + (svref (finite-sb-live-tns sb) i)) + (load-tn-offset-conflicts-in-sb op sb i)))) + (when res (return res)))))) ;;; If a load-TN for OP is targeted to a legal location in SC, then ;;; return the offset, otherwise return NIL. We see whether the target @@ -1007,12 +1007,12 @@ (let ((target (tn-ref-target op))) (when target (let* ((tn (tn-ref-tn target)) - (loc (tn-offset tn))) - (if (and (eq (tn-sc tn) sc) - (member (the index loc) (sc-locations sc)) - (not (load-tn-conflicts-in-sc op sc loc nil))) - loc - nil))))) + (loc (tn-offset tn))) + (if (and (eq (tn-sc tn) sc) + (member (the index loc) (sc-locations sc)) + (not (load-tn-conflicts-in-sc op sc loc nil))) + loc + nil))))) ;;; Select a legal location for a load TN for Op in SC. We just ;;; iterate over the SC's locations. If we can't find a legal @@ -1024,11 +1024,11 @@ (let ((target (tn-ref-target op))) (when target (let* ((tn (tn-ref-tn target)) - (loc (tn-offset tn))) - (when (and (eq (sc-sb sc) (sc-sb (tn-sc tn))) - (member (the index loc) (sc-locations sc)) - (not (load-tn-conflicts-in-sc op sc loc nil))) - (return-from select-load-tn-location loc))))) + (loc (tn-offset tn))) + (when (and (eq (sc-sb sc) (sc-sb (tn-sc tn))) + (member (the index loc) (sc-locations sc)) + (not (load-tn-conflicts-in-sc op sc loc nil))) + (return-from select-load-tn-location loc))))) (dolist (loc (sc-locations sc) nil) (unless (load-tn-conflicts-in-sc op sc loc nil) @@ -1043,16 +1043,16 @@ (defun unpack-tn (tn) (event unpack-tn) (let ((stn (or (tn-save-tn tn) - (pack-save-tn tn)))) + (pack-save-tn tn)))) (setf (tn-sc tn) (tn-sc stn)) (setf (tn-offset tn) (tn-offset stn)) (flet ((zot (refs) - (do ((ref refs (tn-ref-next ref))) - ((null ref)) - (let ((vop (tn-ref-vop ref))) - (if (eq (vop-info-name (vop-info vop)) 'move-operand) - (delete-vop vop) - (setf (gethash (vop-block vop) *repack-blocks*) t)))))) + (do ((ref refs (tn-ref-next ref))) + ((null ref)) + (let ((vop (tn-ref-vop ref))) + (if (eq (vop-info-name (vop-info vop)) 'move-operand) + (delete-vop vop) + (setf (gethash (vop-block vop) *repack-blocks*) t)))))) (zot (tn-reads tn)) (zot (tn-writes tn)))) @@ -1074,45 +1074,45 @@ (defun unpack-for-load-tn (sc op) (declare (type sc sc) (type tn-ref op)) (let ((sb (sc-sb sc)) - (normal-tns (ir2-component-normal-tns - (component-info *component-being-compiled*))) - (node (vop-node (tn-ref-vop op))) - (fallback nil)) + (normal-tns (ir2-component-normal-tns + (component-info *component-being-compiled*))) + (node (vop-node (tn-ref-vop op))) + (fallback nil)) (flet ((unpack-em (victims) - (unless *repack-blocks* - (setq *repack-blocks* (make-hash-table :test 'eq))) - (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t) - (dolist (victim victims) - (event unpack-tn node) - (unpack-tn victim)) - (throw 'unpacked-tn nil))) + (unless *repack-blocks* + (setq *repack-blocks* (make-hash-table :test 'eq))) + (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t) + (dolist (victim victims) + (event unpack-tn node) + (unpack-tn victim)) + (throw 'unpacked-tn nil))) (dolist (loc (sc-locations sc)) - (declare (type index loc)) - (block SKIP - (collect ((victims nil adjoin)) - (do ((i loc (1+ i)) - (end (+ loc (sc-element-size sc)))) - ((= i end)) - (declare (type index i end)) - (let ((victim (svref (finite-sb-live-tns sb) i))) - (when victim - (unless (find-in #'tn-next victim normal-tns) - (return-from SKIP)) - (victims victim)))) - - (let ((conf (load-tn-conflicts-in-sc op sc loc t))) - (cond ((not conf) - (unpack-em (victims))) - ((eq conf :overflow)) - ((not fallback) - (cond ((find conf (victims)) - (setq fallback (victims))) - ((find-in #'tn-next conf normal-tns) - (setq fallback (list conf)))))))))) + (declare (type index loc)) + (block SKIP + (collect ((victims nil adjoin)) + (do ((i loc (1+ i)) + (end (+ loc (sc-element-size sc)))) + ((= i end)) + (declare (type index i end)) + (let ((victim (svref (finite-sb-live-tns sb) i))) + (when victim + (unless (find-in #'tn-next victim normal-tns) + (return-from SKIP)) + (victims victim)))) + + (let ((conf (load-tn-conflicts-in-sc op sc loc t))) + (cond ((not conf) + (unpack-em (victims))) + ((eq conf :overflow)) + ((not fallback) + (cond ((find conf (victims)) + (setq fallback (victims))) + ((find-in #'tn-next conf normal-tns) + (setq fallback (list conf)))))))))) (when fallback - (event unpack-fallback node) - (unpack-em fallback)))) + (event unpack-fallback node) + (unpack-em fallback)))) nil) @@ -1134,29 +1134,29 @@ (compute-live-tns (vop-block vop) vop)) (let* ((tn (tn-ref-tn op)) - (ptype (tn-primitive-type tn)) - (scs (svref load-scs (sc-number (tn-sc tn))))) + (ptype (tn-primitive-type tn)) + (scs (svref load-scs (sc-number (tn-sc tn))))) (let ((current-scs scs) - (allowed ())) + (allowed ())) (loop - (cond - ((null current-scs) - (unless allowed - (no-load-scs-allowed-by-primitive-type-error op)) - (dolist (sc allowed) - (unpack-for-load-tn sc op)) - (failed-to-pack-load-tn-error allowed op)) - (t - (let* ((sc (svref *backend-sc-numbers* (pop current-scs))) - (target (find-load-tn-target op sc))) - (when (or target (sc-allowed-by-primitive-type sc ptype)) - (let ((loc (or target - (select-load-tn-location op sc)))) - (when loc - (let ((res (make-tn 0 :load nil sc))) - (setf (tn-offset res) loc) - (return res)))) - (push sc allowed))))))))) + (cond + ((null current-scs) + (unless allowed + (no-load-scs-allowed-by-primitive-type-error op)) + (dolist (sc allowed) + (unpack-for-load-tn sc op)) + (failed-to-pack-load-tn-error allowed op)) + (t + (let* ((sc (svref *backend-sc-numbers* (pop current-scs))) + (target (find-load-tn-target op sc))) + (when (or target (sc-allowed-by-primitive-type sc ptype)) + (let ((loc (or target + (select-load-tn-location op sc)))) + (when loc + (let ((res (make-tn 0 :load nil sc))) + (setf (tn-offset res) loc) + (return res)))) + (push sc allowed))))))))) ;;; Scan a list of load-SCs vectors and a list of TN-REFS threaded by ;;; TN-REF-ACROSS. When we find a reference whose TN doesn't satisfy @@ -1172,31 +1172,31 @@ (op ops (tn-ref-across op))) ((null scs)) (let ((target (tn-ref-target op))) - (when target - (let* ((load-tn (tn-ref-load-tn op)) - (load-scs (svref (car scs) - (sc-number - (tn-sc (or load-tn (tn-ref-tn op))))))) - (if load-tn - (aver (eq load-scs t)) - (unless (eq load-scs t) - (setf (tn-ref-load-tn op) - (pack-load-tn (car scs) op)))))))) + (when target + (let* ((load-tn (tn-ref-load-tn op)) + (load-scs (svref (car scs) + (sc-number + (tn-sc (or load-tn (tn-ref-tn op))))))) + (if load-tn + (aver (eq load-scs t)) + (unless (eq load-scs t) + (setf (tn-ref-load-tn op) + (pack-load-tn (car scs) op)))))))) (do ((scs scs (cdr scs)) (op ops (tn-ref-across op))) ((null scs)) (let ((target (tn-ref-target op))) - (unless target - (let* ((load-tn (tn-ref-load-tn op)) - (load-scs (svref (car scs) - (sc-number - (tn-sc (or load-tn (tn-ref-tn op))))))) - (if load-tn - (aver (eq load-scs t)) - (unless (eq load-scs t) - (setf (tn-ref-load-tn op) - (pack-load-tn (car scs) op)))))))) + (unless target + (let* ((load-tn (tn-ref-load-tn op)) + (load-scs (svref (car scs) + (sc-number + (tn-sc (or load-tn (tn-ref-tn op))))))) + (if load-tn + (aver (eq load-scs t)) + (unless (eq load-scs t) + (setf (tn-ref-load-tn op) + (pack-load-tn (car scs) op)))))))) (values)) @@ -1206,14 +1206,14 @@ (defun pack-load-tns (block) (catch 'unpacked-tn (let ((*live-block* nil) - (*live-vop* nil)) + (*live-vop* nil)) (do ((vop (ir2-block-last-vop block) (vop-prev vop))) - ((null vop)) - (let ((info (vop-info vop))) - (check-operand-restrictions (vop-info-result-load-scs info) - (vop-results vop)) - (check-operand-restrictions (vop-info-arg-load-scs info) - (vop-args vop)))))) + ((null vop)) + (let ((info (vop-info vop))) + (check-operand-restrictions (vop-info-result-load-scs info) + (vop-results vop)) + (check-operand-restrictions (vop-info-arg-load-scs info) + (vop-args vop)))))) (values)) ;;;; targeting @@ -1237,21 +1237,21 @@ (defun check-ok-target (target tn sc) (declare (type tn target tn) (type sc sc) (inline member)) (let* ((loc (tn-offset target)) - (target-sc (tn-sc target)) - (target-sb (sc-sb target-sc))) + (target-sc (tn-sc target)) + (target-sb (sc-sb target-sc))) (declare (type index loc)) ;; We can honor a preference if: ;; -- TARGET's location is in SC's locations. ;; -- The element sizes of the two SCs are the same. ;; -- TN doesn't conflict with target's location. (if (and (eq target-sb (sc-sb sc)) - (or (eq (sb-kind target-sb) :unbounded) - (member loc (sc-locations sc))) - (= (sc-element-size target-sc) (sc-element-size sc)) - (not (conflicts-in-sc tn sc loc)) - (zerop (mod loc (sc-alignment sc)))) - loc - nil))) + (or (eq (sb-kind target-sb) :unbounded) + (member loc (sc-locations sc))) + (= (sc-element-size target-sc) (sc-element-size sc)) + (not (conflicts-in-sc tn sc loc)) + (zerop (mod loc (sc-alignment sc)))) + loc + nil))) ;;; Scan along the target path from TN, looking at readers or writers. ;;; When we find a packed TN, return CHECK-OK-TARGET of that TN. If @@ -1266,25 +1266,25 @@ (defun find-ok-target-offset (tn sc) (declare (type tn tn) (type sc sc)) (flet ((frob-slot (slot-fun) - (declare (type function slot-fun)) - (let ((count 10) - (current tn)) - (declare (type index count)) - (loop - (let ((refs (funcall slot-fun current))) - (unless (and (plusp count) - refs - (not (tn-ref-next refs))) - (return nil)) - (let ((target (tn-ref-target refs))) - (unless target (return nil)) - (setq current (tn-ref-tn target)) - (when (tn-offset current) - (return (check-ok-target current tn sc))) - (decf count))))))) + (declare (type function slot-fun)) + (let ((count 10) + (current tn)) + (declare (type index count)) + (loop + (let ((refs (funcall slot-fun current))) + (unless (and (plusp count) + refs + (not (tn-ref-next refs))) + (return nil)) + (let ((target (tn-ref-target refs))) + (unless target (return nil)) + (setq current (tn-ref-tn target)) + (when (tn-offset current) + (return (check-ok-target current tn sc))) + (decf count))))))) (declare (inline frob-slot)) ; until DYNAMIC-EXTENT works (or (frob-slot #'tn-reads) - (frob-slot #'tn-writes)))) + (frob-slot #'tn-writes)))) ;;;; location selection @@ -1303,38 +1303,38 @@ (defun select-location (tn sc &key use-reserved-locs optimize) (declare (type tn tn) (type sc sc) (inline member)) (let* ((sb (sc-sb sc)) - (element-size (sc-element-size sc)) - (alignment (sc-alignment sc)) - (align-mask (1- alignment)) - (size (finite-sb-current-size sb))) + (element-size (sc-element-size sc)) + (alignment (sc-alignment sc)) + (align-mask (1- alignment)) + (size (finite-sb-current-size sb))) (flet ((attempt-location (start-offset) - (dotimes (i element-size - (return-from select-location start-offset)) - (declare (type index i)) - (let ((offset (+ start-offset i))) - (when (offset-conflicts-in-sb tn sb offset) - (return (logandc2 (the index (+ (the index (1+ offset)) - align-mask)) - align-mask))))))) + (dotimes (i element-size + (return-from select-location start-offset)) + (declare (type index i)) + (let ((offset (+ start-offset i))) + (when (offset-conflicts-in-sb tn sb offset) + (return (logandc2 (the index (+ (the index (1+ offset)) + align-mask)) + align-mask))))))) (if (eq (sb-kind sb) :unbounded) - (loop with offset = 0 - until (> (+ offset element-size) size) do - (setf offset (attempt-location offset))) - (let ((locations (sc-locations sc))) - (when optimize - (setf locations - (stable-sort (copy-list locations) #'> - :key (lambda (location-offset) - (loop for offset from location-offset - repeat element-size - maximize (svref - (finite-sb-always-live-count sb) - offset)))))) - (dolist (offset locations) - (when (or use-reserved-locs - (not (member offset - (sc-reserve-locations sc)))) - (attempt-location offset)))))))) + (loop with offset = 0 + until (> (+ offset element-size) size) do + (setf offset (attempt-location offset))) + (let ((locations (sc-locations sc))) + (when optimize + (setf locations + (stable-sort (copy-list locations) #'> + :key (lambda (location-offset) + (loop for offset from location-offset + repeat element-size + maximize (svref + (finite-sb-always-live-count sb) + offset)))))) + (dolist (offset locations) + (when (or use-reserved-locs + (not (member offset + (sc-reserve-locations sc)))) + (attempt-location offset)))))))) ;;; If a save TN, return the saved TN, otherwise return TN. This is ;;; useful for getting the conflicts of a TN that might be a save TN. @@ -1359,37 +1359,37 @@ (defun pack-tn (tn restricted optimize) (declare (type tn tn)) (let* ((original (original-tn tn)) - (fsc (tn-sc tn)) - (alternates (unless restricted (sc-alternate-scs fsc))) - (save (tn-save-tn tn)) - (specified-save-sc - (when (and save - (eq (tn-kind save) :specified-save)) - (tn-sc save)))) + (fsc (tn-sc tn)) + (alternates (unless restricted (sc-alternate-scs fsc))) + (save (tn-save-tn tn)) + (specified-save-sc + (when (and save + (eq (tn-kind save) :specified-save)) + (tn-sc save)))) (do ((sc fsc (pop alternates))) - ((null sc) - (failed-to-pack-error tn restricted)) + ((null sc) + (failed-to-pack-error tn restricted)) (when (eq sc specified-save-sc) - (unless (tn-offset save) - (pack-tn save nil optimize)) - (setf (tn-offset tn) (tn-offset save)) - (setf (tn-sc tn) (tn-sc save)) - (return)) + (unless (tn-offset save) + (pack-tn save nil optimize)) + (setf (tn-offset tn) (tn-offset save)) + (setf (tn-sc tn) (tn-sc save)) + (return)) (when (or restricted - (not (and (minusp (tn-cost tn)) (sc-save-p sc)))) - (let ((loc (or (find-ok-target-offset original sc) - (select-location original sc) - (and restricted - (select-location original sc :use-reserved-locs t)) - (when (eq (sb-kind (sc-sb sc)) :unbounded) - (grow-sc sc) - (or (select-location original sc) - (error "failed to pack after growing SC?")))))) - (when loc - (add-location-conflicts original sc loc optimize) - (setf (tn-sc tn) sc) - (setf (tn-offset tn) loc) - (return)))))) + (not (and (minusp (tn-cost tn)) (sc-save-p sc)))) + (let ((loc (or (find-ok-target-offset original sc) + (select-location original sc) + (and restricted + (select-location original sc :use-reserved-locs t)) + (when (eq (sb-kind (sc-sb sc)) :unbounded) + (grow-sc sc) + (or (select-location original sc) + (error "failed to pack after growing SC?")))))) + (when loc + (add-location-conflicts original sc loc optimize) + (setf (tn-sc tn) sc) + (setf (tn-offset tn) loc) + (return)))))) (values)) ;;; Pack a wired TN, checking that the offset is in bounds for the SB, @@ -1405,13 +1405,13 @@ (defun pack-wired-tn (tn optimize) (declare (type tn tn)) (let* ((sc (tn-sc tn)) - (sb (sc-sb sc)) - (offset (tn-offset tn)) - (end (+ offset (sc-element-size sc))) - (original (original-tn tn))) + (sb (sc-sb sc)) + (offset (tn-offset tn)) + (end (+ offset (sc-element-size sc))) + (original (original-tn tn))) (when (> end (finite-sb-current-size sb)) (unless (eq (sb-kind sb) :unbounded) - (error "~S is wired to a location that is out of bounds." tn)) + (error "~S is wired to a location that is out of bounds." tn)) (grow-sc sc end)) ;; For non-x86 ports the presence of a save-tn associated with a @@ -1419,26 +1419,26 @@ ;; on the old-fp and return-pc being passed in registers. #!-(or x86 x86-64) (when (and (not (eq (tn-kind tn) :specified-save)) - (conflicts-in-sc original sc offset)) + (conflicts-in-sc original sc offset)) (error "~S is wired to a location that it conflicts with." tn)) ;; Use the above check, but only print a verbose warning. This can ;; be helpful for debugging the x86 port. #+nil (when (and (not (eq (tn-kind tn) :specified-save)) - (conflicts-in-sc original sc offset)) - (format t "~&* Pack-wired-tn possible conflict:~% ~ + (conflicts-in-sc original sc offset)) + (format t "~&* Pack-wired-tn possible conflict:~% ~ tn: ~S; tn-kind: ~S~% ~ sc: ~S~% ~ sb: ~S; sb-name: ~S; sb-kind: ~S~% ~ offset: ~S; end: ~S~% ~ original ~S~% ~ tn-save-tn: ~S; tn-kind of tn-save-tn: ~S~%" - tn (tn-kind tn) sc - sb (sb-name sb) (sb-kind sb) - offset end - original - (tn-save-tn tn) (tn-kind (tn-save-tn tn)))) + tn (tn-kind tn) sc + sb (sb-name sb) (sb-kind sb) + offset end + original + (tn-save-tn tn) (tn-kind (tn-save-tn tn)))) ;; On the x86 ports the old-fp and return-pc are often passed on ;; the stack so the above hack for the other ports does not always @@ -1446,10 +1446,10 @@ ;; on the stack in their standard save locations. #!+(or x86 x86-64) (when (and (not (eq (tn-kind tn) :specified-save)) - (not (and (string= (sb-name sb) "STACK") - (or (= offset 0) - (= offset 1)))) - (conflicts-in-sc original sc offset)) + (not (and (string= (sb-name sb) "STACK") + (or (= offset 0) + (= offset 1)))) + (conflicts-in-sc original sc offset)) (error "~S is wired to a location that it conflicts with." tn)) (add-location-conflicts original sc offset optimize))) @@ -1476,142 +1476,142 @@ (dolist (sb *backend-sb-list*) (unless (eq (sb-kind sb) :non-packed) (let ((size (sb-size sb))) - (fill (finite-sb-always-live sb) nil) - (setf (finite-sb-always-live sb) - (make-array size - :initial-element - #-sb-xc #* - ;; The cross-compiler isn't very good at - ;; dumping specialized arrays, so we delay - ;; construction of this SIMPLE-BIT-VECTOR - ;; until runtime. - #+sb-xc (make-array 0 :element-type 'bit))) - (setf (finite-sb-always-live-count sb) - (make-array size - :initial-element - #-sb-xc #* - ;; Ibid - #+sb-xc (make-array 0 :element-type 'fixnum))) - - (fill (finite-sb-conflicts sb) nil) - (setf (finite-sb-conflicts sb) - (make-array size :initial-element '#())) - - (fill (finite-sb-live-tns sb) nil) - (setf (finite-sb-live-tns sb) - (make-array size :initial-element nil)))))) + (fill (finite-sb-always-live sb) nil) + (setf (finite-sb-always-live sb) + (make-array size + :initial-element + #-sb-xc #* + ;; The cross-compiler isn't very good at + ;; dumping specialized arrays, so we delay + ;; construction of this SIMPLE-BIT-VECTOR + ;; until runtime. + #+sb-xc (make-array 0 :element-type 'bit))) + (setf (finite-sb-always-live-count sb) + (make-array size + :initial-element + #-sb-xc #* + ;; Ibid + #+sb-xc (make-array 0 :element-type 'fixnum))) + + (fill (finite-sb-conflicts sb) nil) + (setf (finite-sb-conflicts sb) + (make-array size :initial-element '#())) + + (fill (finite-sb-live-tns sb) nil) + (setf (finite-sb-live-tns sb) + (make-array size :initial-element nil)))))) (defun pack (component) (unwind-protect (let ((optimize nil) - (2comp (component-info component))) - (init-sb-vectors component) - - ;; Determine whether we want to do more expensive packing by - ;; checking whether any blocks in the component have (> SPEED - ;; COMPILE-SPEED). - ;; - ;; FIXME: This means that a declaration can have a minor - ;; effect even outside its scope, and as the packing is done - ;; component-globally it'd be tricky to use strict scoping. I - ;; think this is still acceptable since it's just a tradeoff - ;; between compilation speed and allocation quality and - ;; doesn't affect the semantics of the generated code in any - ;; way. -- JES 2004-10-06 - (do-ir2-blocks (block component) - (when (policy (block-last (ir2-block-block block)) - (> speed compilation-speed)) - (setf optimize t) - (return))) - - ;; Call the target functions. - (do-ir2-blocks (block component) - (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop)) - (let ((target-fun (vop-info-target-fun (vop-info vop)))) - (when target-fun - (funcall target-fun vop))))) - - ;; Pack wired TNs first. - (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn))) - ((null tn)) - (pack-wired-tn tn optimize)) - - ;; Pack restricted component TNs. - (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn))) - ((null tn)) - (when (eq (tn-kind tn) :component) - (pack-tn tn t optimize))) - - ;; Pack other restricted TNs. - (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn))) - ((null tn)) - (unless (tn-offset tn) - (pack-tn tn t optimize))) - - ;; Assign costs to normal TNs so we know which ones should - ;; always be packed on the stack. - (when *pack-assign-costs* - (assign-tn-costs component) - (assign-tn-depths component)) - - ;; Allocate normal TNs, starting with the TNs that are used - ;; in deep loops. - (collect ((tns)) - (do-ir2-blocks (block component) - (let ((ltns (ir2-block-local-tns block))) - (do ((i (1- (ir2-block-local-tn-count block)) (1- i))) - ((minusp i)) - (declare (fixnum i)) - (let ((tn (svref ltns i))) - (unless (or (null tn) - (eq tn :more) - (tn-offset tn)) - ;; If loop analysis has been disabled we might as - ;; well revert to the old behaviour of just - ;; packing TNs linearly as they appear. - (unless *loop-analyze* - (pack-tn tn nil optimize)) - (tns tn)))))) - (dolist (tn (stable-sort (tns) - (lambda (a b) - (cond - ((> (tn-loop-depth a) - (tn-loop-depth b)) - t) - ((= (tn-loop-depth a) - (tn-loop-depth b)) - (> (tn-cost a) (tn-cost b))) - (t nil))))) - (unless (tn-offset tn) - (pack-tn tn nil optimize)))) - - ;; Pack any leftover normal TNs. This is to deal with :MORE TNs, - ;; which could possibly not appear in any local TN map. - (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn))) - ((null tn)) - (unless (tn-offset tn) - (pack-tn tn nil optimize))) - - ;; Do load TN packing and emit saves. - (let ((*repack-blocks* nil)) - (cond ((and optimize *pack-optimize-saves*) - (optimized-emit-saves component) - (do-ir2-blocks (block component) - (pack-load-tns block))) - (t - (do-ir2-blocks (block component) - (emit-saves block) - (pack-load-tns block)))) - (when *repack-blocks* - (loop - (when (zerop (hash-table-count *repack-blocks*)) (return)) - (maphash (lambda (block v) - (declare (ignore v)) - (remhash block *repack-blocks*) - (event repack-block) - (pack-load-tns block)) - *repack-blocks*)))) - - (values)) + (2comp (component-info component))) + (init-sb-vectors component) + + ;; Determine whether we want to do more expensive packing by + ;; checking whether any blocks in the component have (> SPEED + ;; COMPILE-SPEED). + ;; + ;; FIXME: This means that a declaration can have a minor + ;; effect even outside its scope, and as the packing is done + ;; component-globally it'd be tricky to use strict scoping. I + ;; think this is still acceptable since it's just a tradeoff + ;; between compilation speed and allocation quality and + ;; doesn't affect the semantics of the generated code in any + ;; way. -- JES 2004-10-06 + (do-ir2-blocks (block component) + (when (policy (block-last (ir2-block-block block)) + (> speed compilation-speed)) + (setf optimize t) + (return))) + + ;; Call the target functions. + (do-ir2-blocks (block component) + (do ((vop (ir2-block-start-vop block) (vop-next vop))) + ((null vop)) + (let ((target-fun (vop-info-target-fun (vop-info vop)))) + (when target-fun + (funcall target-fun vop))))) + + ;; Pack wired TNs first. + (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn))) + ((null tn)) + (pack-wired-tn tn optimize)) + + ;; Pack restricted component TNs. + (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn))) + ((null tn)) + (when (eq (tn-kind tn) :component) + (pack-tn tn t optimize))) + + ;; Pack other restricted TNs. + (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn))) + ((null tn)) + (unless (tn-offset tn) + (pack-tn tn t optimize))) + + ;; Assign costs to normal TNs so we know which ones should + ;; always be packed on the stack. + (when *pack-assign-costs* + (assign-tn-costs component) + (assign-tn-depths component)) + + ;; Allocate normal TNs, starting with the TNs that are used + ;; in deep loops. + (collect ((tns)) + (do-ir2-blocks (block component) + (let ((ltns (ir2-block-local-tns block))) + (do ((i (1- (ir2-block-local-tn-count block)) (1- i))) + ((minusp i)) + (declare (fixnum i)) + (let ((tn (svref ltns i))) + (unless (or (null tn) + (eq tn :more) + (tn-offset tn)) + ;; If loop analysis has been disabled we might as + ;; well revert to the old behaviour of just + ;; packing TNs linearly as they appear. + (unless *loop-analyze* + (pack-tn tn nil optimize)) + (tns tn)))))) + (dolist (tn (stable-sort (tns) + (lambda (a b) + (cond + ((> (tn-loop-depth a) + (tn-loop-depth b)) + t) + ((= (tn-loop-depth a) + (tn-loop-depth b)) + (> (tn-cost a) (tn-cost b))) + (t nil))))) + (unless (tn-offset tn) + (pack-tn tn nil optimize)))) + + ;; Pack any leftover normal TNs. This is to deal with :MORE TNs, + ;; which could possibly not appear in any local TN map. + (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn))) + ((null tn)) + (unless (tn-offset tn) + (pack-tn tn nil optimize))) + + ;; Do load TN packing and emit saves. + (let ((*repack-blocks* nil)) + (cond ((and optimize *pack-optimize-saves*) + (optimized-emit-saves component) + (do-ir2-blocks (block component) + (pack-load-tns block))) + (t + (do-ir2-blocks (block component) + (emit-saves block) + (pack-load-tns block)))) + (when *repack-blocks* + (loop + (when (zerop (hash-table-count *repack-blocks*)) (return)) + (maphash (lambda (block v) + (declare (ignore v)) + (remhash block *repack-blocks*) + (event repack-block) + (pack-load-tns block)) + *repack-blocks*)))) + + (values)) (clean-up-pack-structures))) diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 6109cbd..d98953b 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -37,11 +37,11 @@ (declaim (ftype (sfunction (list) (values list list boolean t boolean list boolean boolean list boolean t t boolean)) - parse-lambda-list-like-thing)) + parse-lambda-list-like-thing)) (declaim (ftype (sfunction (list) (values list list boolean t boolean list boolean boolean list boolean t t)) - parse-lambda-list)) + parse-lambda-list)) (defun parse-lambda-list-like-thing (list) (collect ((required) (optional) @@ -53,7 +53,7 @@ (more-context nil) (more-count nil) (keyp nil) - (auxp nil) + (auxp nil) (allowp nil) (state :required)) (declare (type (member :allow-other-keys :aux @@ -84,10 +84,10 @@ (unless (member state '(:required :optional :post-rest :post-more)) (compiler-error "misplaced &KEY in lambda list: ~S" list)) - #-sb-xc-host - (when (optional) - (compiler-style-warn - "&OPTIONAL and &KEY found in the same lambda list: ~S" list)) + #-sb-xc-host + (when (optional) + (compiler-style-warn + "&OPTIONAL and &KEY found in the same lambda list: ~S" list)) (setq keyp t state :key)) (&allow-other-keys @@ -103,34 +103,34 @@ (when auxp (compiler-error "multiple &AUX in lambda list: ~S" list)) (setq auxp t - state :aux)) + state :aux)) (t (bug "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg))) - (progn - (when (symbolp arg) - (let ((name (symbol-name arg))) - (when (and (plusp (length name)) - (char= (char name 0) #\&)) - (style-warn - "suspicious variable in lambda list: ~S." arg)))) - (case state - (:required (required arg)) - (:optional (optional arg)) - (:rest - (setq restp t - rest arg - state :post-rest)) - (:more-context - (setq more-context arg - state :more-count)) - (:more-count - (setq more-count arg - state :post-more)) - (:key (keys arg)) - (:aux (aux arg)) - (t - (compiler-error "found garbage in lambda list when expecting ~ + (progn + (when (symbolp arg) + (let ((name (symbol-name arg))) + (when (and (plusp (length name)) + (char= (char name 0) #\&)) + (style-warn + "suspicious variable in lambda list: ~S." arg)))) + (case state + (:required (required arg)) + (:optional (optional arg)) + (:rest + (setq restp t + rest arg + state :post-rest)) + (:more-context + (setq more-context arg + state :more-count)) + (:more-count + (setq more-count arg + state :post-more)) + (:key (keys arg)) + (:aux (aux arg)) + (t + (compiler-error "found garbage in lambda list when expecting ~ a keyword: ~S" - arg)))))) + arg)))))) (when (eq state :rest) (compiler-error "&REST without rest variable")) @@ -147,45 +147,45 @@ ;; Classify parameters without checking their validity individually. (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux - morep more-context more-count) + morep more-context more-count) (parse-lambda-list-like-thing lambda-list) ;; Check validity of parameters. (flet ((need-symbol (x why) - (unless (symbolp x) - (compiler-error "~A is not a symbol: ~S" why x)))) + (unless (symbolp x) + (compiler-error "~A is not a symbol: ~S" why x)))) (dolist (i required) - (need-symbol i "Required argument")) + (need-symbol i "Required argument")) (dolist (i optional) - (typecase i - (symbol) - (cons - (destructuring-bind (var &optional init-form supplied-p) i - (declare (ignore init-form supplied-p)) - (need-symbol var "&OPTIONAL parameter name"))) - (t - (compiler-error "&OPTIONAL parameter is not a symbol or cons: ~S" - i)))) + (typecase i + (symbol) + (cons + (destructuring-bind (var &optional init-form supplied-p) i + (declare (ignore init-form supplied-p)) + (need-symbol var "&OPTIONAL parameter name"))) + (t + (compiler-error "&OPTIONAL parameter is not a symbol or cons: ~S" + i)))) (when restp - (need-symbol rest "&REST argument")) + (need-symbol rest "&REST argument")) (when keyp - (dolist (i keys) - (typecase i - (symbol) - (cons - (destructuring-bind (var-or-kv &optional init-form supplied-p) i - (declare (ignore init-form supplied-p)) - (if (consp var-or-kv) - (destructuring-bind (keyword-name var) var-or-kv - (declare (ignore keyword-name)) - (need-symbol var "&KEY parameter name")) - (need-symbol var-or-kv "&KEY parameter name")))) - (t - (compiler-error "&KEY parameter is not a symbol or cons: ~S" - i)))))) + (dolist (i keys) + (typecase i + (symbol) + (cons + (destructuring-bind (var-or-kv &optional init-form supplied-p) i + (declare (ignore init-form supplied-p)) + (if (consp var-or-kv) + (destructuring-bind (keyword-name var) var-or-kv + (declare (ignore keyword-name)) + (need-symbol var "&KEY parameter name")) + (need-symbol var-or-kv "&KEY parameter name")))) + (t + (compiler-error "&KEY parameter is not a symbol or cons: ~S" + i)))))) ;; Voila. (values required optional restp rest keyp keys allowp auxp aux - morep more-context more-count))) + morep more-context more-count))) (/show0 "parse-lambda-list.lisp end of file") diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index cd54ff2..540b29c 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -17,7 +17,7 @@ ;;; Do environment analysis on the code in COMPONENT. This involves ;;; various things: -;;; 1. Make a PHYSENV structure for each non-LET LAMBDA, assigning +;;; 1. Make a PHYSENV structure for each non-LET LAMBDA, assigning ;;; the LAMBDA-PHYSENV for all LAMBDAs. ;;; 2. Find all values that need to be closed over by each ;;; physical environment. @@ -25,17 +25,17 @@ ;;; continuations. ;;; 4. Delete all non-top-level functions with no references. This ;;; should only get functions with non-NULL kinds, since normal -;;; functions are deleted when their references go to zero. +;;; functions are deleted when their references go to zero. (defun physenv-analyze (component) (declare (type component component)) (aver (every (lambda (x) - (eq (functional-kind x) :deleted)) - (component-new-functionals component))) + (eq (functional-kind x) :deleted)) + (component-new-functionals component))) (setf (component-new-functionals component) ()) (dolist (clambda (component-lambdas component)) (reinit-lambda-physenv clambda)) (mapc #'add-lambda-vars-and-let-vars-to-closures - (component-lambdas component)) + (component-lambdas component)) (find-non-local-exits component) (recheck-dynamic-extent-lvars component) @@ -45,10 +45,10 @@ (dolist (fun (component-lambdas component)) (when (null (leaf-refs fun)) (let ((kind (functional-kind fun))) - (unless (or (eq kind :toplevel) - (functional-has-external-references-p fun)) - (aver (member kind '(:optional :cleanup :escape))) - (setf (functional-kind fun) nil) + (unless (or (eq kind :toplevel) + (functional-has-external-references-p fun)) + (aver (member kind '(:optional :cleanup :escape))) + (setf (functional-kind fun) nil) (delete-functional fun))))) (setf (component-nlx-info-generated-p component) t) @@ -66,7 +66,7 @@ (let ((found-it nil)) (dolist (lambda (component-lambdas component)) (when (add-lambda-vars-and-let-vars-to-closures lambda) - (setq found-it t))) + (setq found-it t))) found-it)) ;;; If CLAMBDA has a PHYSENV, return it, otherwise assign an empty one @@ -75,17 +75,17 @@ (declare (type clambda clambda)) (let ((homefun (lambda-home clambda))) (or (lambda-physenv homefun) - (let ((res (make-physenv :lambda homefun))) - (setf (lambda-physenv homefun) res) - ;; All the LETLAMBDAs belong to HOMEFUN, and share the same - ;; PHYSENV. Thus, (1) since HOMEFUN's PHYSENV was NIL, - ;; theirs should be NIL too, and (2) since we're modifying - ;; HOMEFUN's PHYSENV, we should modify theirs, too. - (dolist (letlambda (lambda-lets homefun)) - (aver (eql (lambda-home letlambda) homefun)) - (aver (null (lambda-physenv letlambda))) - (setf (lambda-physenv letlambda) res)) - res)))) + (let ((res (make-physenv :lambda homefun))) + (setf (lambda-physenv homefun) res) + ;; All the LETLAMBDAs belong to HOMEFUN, and share the same + ;; PHYSENV. Thus, (1) since HOMEFUN's PHYSENV was NIL, + ;; theirs should be NIL too, and (2) since we're modifying + ;; HOMEFUN's PHYSENV, we should modify theirs, too. + (dolist (letlambda (lambda-lets homefun)) + (aver (eql (lambda-home letlambda) homefun)) + (aver (null (lambda-physenv letlambda))) + (setf (lambda-physenv letlambda) res)) + res)))) ;;; If FUN has no physical environment, assign one, otherwise clean up ;;; the old physical environment, removing/flagging variables that @@ -95,18 +95,18 @@ (defun reinit-lambda-physenv (fun) (let ((old (lambda-physenv (lambda-home fun)))) (cond (old - (setf (physenv-closure old) - (delete-if (lambda (x) - (and (lambda-var-p x) - (null (leaf-refs x)))) - (physenv-closure old))) - (flet ((clear (fun) - (dolist (var (lambda-vars fun)) - (setf (lambda-var-indirect var) nil)))) - (clear fun) - (map nil #'clear (lambda-lets fun)))) - (t - (get-lambda-physenv fun)))) + (setf (physenv-closure old) + (delete-if (lambda (x) + (and (lambda-var-p x) + (null (leaf-refs x)))) + (physenv-closure old))) + (flet ((clear (fun) + (dolist (var (lambda-vars fun)) + (setf (lambda-var-indirect var) nil)))) + (clear fun) + (map nil #'clear (lambda-lets fun)))) + (t + (get-lambda-physenv fun)))) (values)) ;;; Get NODE's environment, assigning one if necessary. @@ -125,33 +125,33 @@ ;;; the LAMBDA-VARS of CLAMBDA's LAMBDA-LETS. (defun %add-lambda-vars-to-closures (clambda) (let ((physenv (get-lambda-physenv clambda)) - (did-something nil)) + (did-something nil)) (note-unreferenced-vars clambda) (dolist (var (lambda-vars clambda)) (dolist (ref (leaf-refs var)) - (let ((ref-physenv (get-node-physenv ref))) - (unless (eq ref-physenv physenv) - (when (lambda-var-sets var) - (setf (lambda-var-indirect var) t)) - (setq did-something t) - (close-over var ref-physenv physenv)))) + (let ((ref-physenv (get-node-physenv ref))) + (unless (eq ref-physenv physenv) + (when (lambda-var-sets var) + (setf (lambda-var-indirect var) t)) + (setq did-something t) + (close-over var ref-physenv physenv)))) (dolist (set (basic-var-sets var)) - ;; Variables which are set but never referenced can be - ;; optimized away, and closing over them here would just - ;; interfere with that. (In bug 147, it *did* interfere with - ;; that, causing confusion later. This UNLESS solves that - ;; problem, but I (WHN) am not 100% sure it's best to solve - ;; the problem this way instead of somehow solving it - ;; somewhere upstream and just doing (AVER (LEAF-REFS VAR)) - ;; here.) - (unless (null (leaf-refs var)) + ;; Variables which are set but never referenced can be + ;; optimized away, and closing over them here would just + ;; interfere with that. (In bug 147, it *did* interfere with + ;; that, causing confusion later. This UNLESS solves that + ;; problem, but I (WHN) am not 100% sure it's best to solve + ;; the problem this way instead of somehow solving it + ;; somewhere upstream and just doing (AVER (LEAF-REFS VAR)) + ;; here.) + (unless (null (leaf-refs var)) - (let ((set-physenv (get-node-physenv set))) - (unless (eq set-physenv physenv) + (let ((set-physenv (get-node-physenv set))) + (unless (eq set-physenv physenv) (setf did-something t - (lambda-var-indirect var) t) - (close-over var set-physenv physenv)))))) + (lambda-var-indirect var) t) + (close-over var set-physenv physenv)))))) did-something)) ;;; Find any variables in CLAMBDA -- either directly in LAMBDA-VARS or @@ -172,7 +172,7 @@ ;; here, since LETS only go one layer deep. (aver (null (lambda-lets lambda-let))) (when (%add-lambda-vars-to-closures lambda-let) - (setf did-something t))) + (setf did-something t))) did-something)) (defun xep-allocator (xep) @@ -239,15 +239,15 @@ (defun insert-nlx-entry-stub (exit env) (declare (type physenv env) (type exit exit)) (let* ((exit-block (node-block exit)) - (next-block (first (block-succ exit-block))) - (entry (exit-entry exit)) - (cleanup (entry-cleanup entry)) - (info (make-nlx-info cleanup exit)) - (new-block (insert-cleanup-code exit-block next-block - entry - `(%nlx-entry ',info) - cleanup)) - (component (block-component new-block))) + (next-block (first (block-succ exit-block))) + (entry (exit-entry exit)) + (cleanup (entry-cleanup entry)) + (info (make-nlx-info cleanup exit)) + (new-block (insert-cleanup-code exit-block next-block + entry + `(%nlx-entry ',info) + cleanup)) + (component (block-component new-block))) (unlink-blocks exit-block new-block) (link-blocks exit-block (component-tail component)) (link-blocks (component-head component) new-block) @@ -259,7 +259,7 @@ (push info (cleanup-nlx-info cleanup)) (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) (setf (node-lexenv (block-last new-block)) - (node-lexenv entry)))) + (node-lexenv entry)))) (values)) @@ -283,7 +283,7 @@ (defun note-non-local-exit (env exit) (declare (type physenv env) (type exit exit)) (let ((lvar (node-lvar exit)) - (exit-fun (node-home-lambda exit)) + (exit-fun (node-home-lambda exit)) (info (find-nlx-info exit))) (cond (info (let ((block (node-block exit))) @@ -322,10 +322,10 @@ (dolist (lambda (component-lambdas component)) (dolist (entry (lambda-entries lambda)) (dolist (exit (entry-exits entry)) - (let ((target-physenv (node-physenv entry))) - (if (eq (node-physenv exit) target-physenv) - (maybe-delete-exit exit) - (note-non-local-exit target-physenv exit)))))) + (let ((target-physenv (node-physenv entry))) + (if (eq (node-physenv exit) target-physenv) + (maybe-delete-exit exit) + (note-non-local-exit target-physenv exit)))))) (values)) ;;;; final decision on stack allocation of dynamic-extent structures @@ -393,38 +393,38 @@ (defun emit-cleanups (block1 block2) (declare (type cblock block1 block2)) (collect ((code) - (reanalyze-funs)) + (reanalyze-funs)) (let ((cleanup2 (block-start-cleanup block2))) (do ((cleanup (block-end-cleanup block1) - (node-enclosing-cleanup (cleanup-mess-up cleanup)))) - ((eq cleanup cleanup2)) - (let* ((node (cleanup-mess-up cleanup)) - (args (when (basic-combination-p node) - (basic-combination-args node)))) - (ecase (cleanup-kind cleanup) - (:special-bind - (code `(%special-unbind ',(lvar-value (first args))))) - (:catch - (code `(%catch-breakup))) - (:unwind-protect - (code `(%unwind-protect-breakup)) - (let ((fun (ref-leaf (lvar-uses (second args))))) - (reanalyze-funs fun) - (code `(%funcall ,fun)))) - ((:block :tagbody) - (dolist (nlx (cleanup-nlx-info cleanup)) - (code `(%lexical-exit-breakup ',nlx)))) - (:dynamic-extent - (when (not (null (cleanup-info cleanup))) + (node-enclosing-cleanup (cleanup-mess-up cleanup)))) + ((eq cleanup cleanup2)) + (let* ((node (cleanup-mess-up cleanup)) + (args (when (basic-combination-p node) + (basic-combination-args node)))) + (ecase (cleanup-kind cleanup) + (:special-bind + (code `(%special-unbind ',(lvar-value (first args))))) + (:catch + (code `(%catch-breakup))) + (:unwind-protect + (code `(%unwind-protect-breakup)) + (let ((fun (ref-leaf (lvar-uses (second args))))) + (reanalyze-funs fun) + (code `(%funcall ,fun)))) + ((:block :tagbody) + (dolist (nlx (cleanup-nlx-info cleanup)) + (code `(%lexical-exit-breakup ',nlx)))) + (:dynamic-extent + (when (not (null (cleanup-info cleanup))) (code `(%cleanup-point))))))) (when (code) - (aver (not (node-tail-p (block-last block1)))) - (insert-cleanup-code block1 block2 - (block-last block1) - `(progn ,@(code))) - (dolist (fun (reanalyze-funs)) - (locall-analyze-fun-1 fun))))) + (aver (not (node-tail-p (block-last block1)))) + (insert-cleanup-code block1 block2 + (block-last block1) + `(progn ,@(code))) + (dolist (fun (reanalyze-funs)) + (locall-analyze-fun-1 fun))))) (values)) @@ -437,18 +437,18 @@ (declare (type component component)) (do-blocks (block1 component) (let ((env1 (block-physenv block1)) - (cleanup1 (block-end-cleanup block1))) + (cleanup1 (block-end-cleanup block1))) (dolist (block2 (block-succ block1)) - (when (block-start block2) - (let ((env2 (block-physenv block2)) - (cleanup2 (block-start-cleanup block2))) - (unless (or (not (eq env2 env1)) - (eq cleanup1 cleanup2) - (and cleanup2 - (eq (node-enclosing-cleanup - (cleanup-mess-up cleanup2)) - cleanup1))) - (emit-cleanups block1 block2))))))) + (when (block-start block2) + (let ((env2 (block-physenv block2)) + (cleanup2 (block-start-cleanup block2))) + (unless (or (not (eq env2 env1)) + (eq cleanup1 cleanup2) + (and cleanup2 + (eq (node-enclosing-cleanup + (cleanup-mess-up cleanup2)) + cleanup1))) + (emit-cleanups block1 block2))))))) (values)) ;;; Mark optimizable tail-recursive uses of function result @@ -471,12 +471,12 @@ ;; backtrace for (defun foo (x) (error "foo ~S" x)) wich seems ;; less then optimal. --NS 2005-02-28 (when ret - (let ((result (return-result ret))) - (do-uses (use result) - (when (and (policy use merge-tail-calls) + (let ((result (return-result ret))) + (do-uses (use result) + (when (and (policy use merge-tail-calls) (basic-combination-p use) - (immediately-used-p result use) - (or (not (eq (node-derived-type use) *empty-type*)) - (eq (basic-combination-kind use) :local))) - (setf (node-tail-p use) t))))))) + (immediately-used-p result use) + (or (not (eq (node-derived-type use) *empty-type*)) + (eq (basic-combination-kind use) :local))) + (setf (node-tail-p use) t))))))) (values)) diff --git a/src/compiler/policies.lisp b/src/compiler/policies.lisp index b62b239..b1d2ee6 100644 --- a/src/compiler/policies.lisp +++ b/src/compiler/policies.lisp @@ -56,9 +56,9 @@ (define-optimization-quality stack-allocate-dynamic-extent (if (and (> (max speed space) (max debug safety)) - (< safety 3)) - 3 - 0) + (< safety 3)) + 3 + 0) ("no" "maybe" "yes" "yes")) (define-optimization-quality stack-allocate-vector diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index bef5b88..fae8e19 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -42,7 +42,7 @@ ;;; Inside the scope of declarations, new entries are added at the ;;; head of the alist. (declaim (type policy *policy*)) -(defvar *policy*) ; initialized in cold init +(defvar *policy*) ; initialized in cold init ;;; This is to be called early in cold init to set things up, and may ;;; also be called again later in cold init in order to reset default @@ -50,31 +50,31 @@ ;;; OPTIMIZE forms have messed with it. (defun !policy-cold-init-or-resanify () (setf *policy-qualities* - '(;; ANSI standard qualities - compilation-speed - debug - safety - space - speed - ;; SBCL extensions - ;; - ;; FIXME: INHIBIT-WARNINGS is a misleading name for this. - ;; Perhaps BREVITY would be better. But the ideal name would - ;; have connotations of suppressing not warnings but only - ;; optimization-related notes, which is already mostly the - ;; behavior, and should probably become the exact behavior. - ;; Perhaps INHIBIT-NOTES? - inhibit-warnings)) + '(;; ANSI standard qualities + compilation-speed + debug + safety + space + speed + ;; SBCL extensions + ;; + ;; FIXME: INHIBIT-WARNINGS is a misleading name for this. + ;; Perhaps BREVITY would be better. But the ideal name would + ;; have connotations of suppressing not warnings but only + ;; optimization-related notes, which is already mostly the + ;; behavior, and should probably become the exact behavior. + ;; Perhaps INHIBIT-NOTES? + inhibit-warnings)) (setf *policy* - (mapcar (lambda (name) - ;; CMU CL didn't use 1 as the default for - ;; everything, but since ANSI says 1 is the ordinary - ;; value, we do. - (cons name 1)) - *policy-qualities*)) + (mapcar (lambda (name) + ;; CMU CL didn't use 1 as the default for + ;; everything, but since ANSI says 1 is the ordinary + ;; value, we do. + (cons name 1)) + *policy-qualities*)) ;; not actually POLICY, but very similar (setf *handled-conditions* nil - *disabled-package-locks* nil)) + *disabled-package-locks* nil)) ;;; On the cross-compilation host, we initialize immediately (not ;;; waiting for "cold init", since cold init doesn't exist on @@ -97,9 +97,9 @@ ;;; referring to them by name, e.g. (> SPEED SPACE). (defmacro policy (thing expr) (let* ((n-policy (gensym "N-POLICY-")) - (binds (mapcar (lambda (name) - `(,name (policy-quality ,n-policy ',name))) - *policy-qualities*)) + (binds (mapcar (lambda (name) + `(,name (policy-quality ,n-policy ',name))) + *policy-qualities*)) (dependent-binds (loop for (name . info) in *policy-dependent-qualities* collect `(,name (policy-quality ,n-policy ',name)) @@ -107,7 +107,7 @@ ,(policy-dependent-quality-expression info) ,name))))) `(let* ((,n-policy (%coerce-to-policy ,thing)) - ,@binds + ,@binds ,@dependent-binds) (declare (ignorable ,@*policy-qualities* ,@(mapcar #'car *policy-dependent-qualities*))) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 3890102..9dd4dc6 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -27,9 +27,9 @@ (collect ((vars)) (dolist (name names (vars)) (unless (symbolp name) - (compiler-error "The name ~S is not a symbol." name)) + (compiler-error "The name ~S is not a symbol." name)) (let ((old (gethash name *free-vars*))) - (when old (vars old)))))) + (when old (vars old)))))) ;;; Return a new POLICY containing the policy information represented ;;; by the optimize declaration SPEC. Any parameters not specified are @@ -40,83 +40,83 @@ ;; Add new entries from SPEC. (dolist (q-and-v-or-just-q (cdr spec)) (multiple-value-bind (quality raw-value) - (if (atom q-and-v-or-just-q) - (values q-and-v-or-just-q 3) - (destructuring-bind (quality raw-value) q-and-v-or-just-q - (values quality raw-value))) - (cond ((not (policy-quality-name-p quality)) - (compiler-warn "ignoring unknown optimization quality ~ + (if (atom q-and-v-or-just-q) + (values q-and-v-or-just-q 3) + (destructuring-bind (quality raw-value) q-and-v-or-just-q + (values quality raw-value))) + (cond ((not (policy-quality-name-p quality)) + (compiler-warn "ignoring unknown optimization quality ~ ~S in ~S" - quality spec)) - ((not (typep raw-value 'policy-quality)) - (compiler-warn "ignoring bad optimization value ~S in ~S" - raw-value spec)) - (t - ;; we can't do this yet, because CLOS macros expand - ;; into code containing INHIBIT-WARNINGS. - #+nil - (when (eql quality 'sb!ext:inhibit-warnings) - (compiler-style-warn "~S is deprecated: use ~S instead" - quality 'sb!ext:muffle-conditions)) - (push (cons quality raw-value) - result))))) + quality spec)) + ((not (typep raw-value 'policy-quality)) + (compiler-warn "ignoring bad optimization value ~S in ~S" + raw-value spec)) + (t + ;; we can't do this yet, because CLOS macros expand + ;; into code containing INHIBIT-WARNINGS. + #+nil + (when (eql quality 'sb!ext:inhibit-warnings) + (compiler-style-warn "~S is deprecated: use ~S instead" + quality 'sb!ext:muffle-conditions)) + (push (cons quality raw-value) + result))))) ;; Add any nonredundant entries from old POLICY. (dolist (old-entry policy) (unless (assq (car old-entry) result) - (push old-entry result))) + (push old-entry result))) ;; Voila. result)) (declaim (ftype (function (list list) list) - process-handle-conditions-decl)) + process-handle-conditions-decl)) (defun process-handle-conditions-decl (spec list) (let ((new (copy-alist list))) (dolist (clause (cdr spec)) (destructuring-bind (typespec restart-name) clause - (let ((ospec (rassoc restart-name new :test #'eq))) - (if ospec - (setf (car ospec) - (type-specifier - (type-union (specifier-type (car ospec)) - (specifier-type typespec)))) - (push (cons (type-specifier (specifier-type typespec)) - restart-name) - new))))) + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (setf (car ospec) + (type-specifier + (type-union (specifier-type (car ospec)) + (specifier-type typespec)))) + (push (cons (type-specifier (specifier-type typespec)) + restart-name) + new))))) new)) (declaim (ftype (function (list list) list) - process-muffle-conditions-decl)) + process-muffle-conditions-decl)) (defun process-muffle-conditions-decl (spec list) (process-handle-conditions-decl (cons 'handle-conditions - (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) list)) (declaim (ftype (function (list list) list) - process-unhandle-conditions-decl)) + process-unhandle-conditions-decl)) (defun process-unhandle-conditions-decl (spec list) (let ((new (copy-alist list))) (dolist (clause (cdr spec)) (destructuring-bind (typespec restart-name) clause - (let ((ospec (rassoc restart-name new :test #'eq))) - (if ospec - (let ((type-specifier - (type-specifier - (type-intersection - (specifier-type (car ospec)) - (specifier-type `(not ,typespec)))))) - (if type-specifier - (setf (car ospec) type-specifier) - (setq new - (delete restart-name new :test #'eq :key #'cdr)))) - ;; do nothing? - nil)))) + (let ((ospec (rassoc restart-name new :test #'eq))) + (if ospec + (let ((type-specifier + (type-specifier + (type-intersection + (specifier-type (car ospec)) + (specifier-type `(not ,typespec)))))) + (if type-specifier + (setf (car ospec) type-specifier) + (setq new + (delete restart-name new :test #'eq :key #'cdr)))) + ;; do nothing? + nil)))) new)) (declaim (ftype (function (list list) list) - process-unmuffle-conditions-decl)) + process-unmuffle-conditions-decl)) (defun process-unmuffle-conditions-decl (spec list) (process-unhandle-conditions-decl (cons 'unhandle-conditions - (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) + (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) list)) (declaim (ftype (function (list list) list) @@ -136,24 +136,24 @@ (defun canonized-decl-spec (decl-spec) (let ((id (first decl-spec))) (let ((id-is-type (if (symbolp id) - (info :type :kind id) - ;; A cons might not be a valid type specifier, - ;; but it can't be a declaration either. - (or (consp id) - (typep id 'class)))) - (id-is-declared-decl (info :declaration :recognized id))) + (info :type :kind id) + ;; A cons might not be a valid type specifier, + ;; but it can't be a declaration either. + (or (consp id) + (typep id 'class)))) + (id-is-declared-decl (info :declaration :recognized id))) ;; FIXME: Checking ID-IS-DECLARED is probably useless these days, ;; since we refuse to use the same symbol as both a type name and - ;; recognized declaration name. + ;; recognized declaration name. (cond ((and id-is-type id-is-declared-decl) - (compiler-error - "ambiguous declaration ~S:~% ~ + (compiler-error + "ambiguous declaration ~S:~% ~ ~S was declared as a DECLARATION, but is also a type name." - decl-spec id)) - (id-is-type - (cons 'type decl-spec)) - (t - decl-spec))))) + decl-spec id)) + (id-is-type + (cons 'type decl-spec)) + (t + decl-spec))))) (defvar *queued-proclaims*) ; initialized in !COLD-INIT-FORMS @@ -165,44 +165,44 @@ #+sb-xc (/show0 "entering PROCLAIM, RAW-FORM=..") #+sb-xc (/hexstr raw-form) (let* ((form (canonized-decl-spec raw-form)) - (kind (first form)) - (args (rest form))) + (kind (first form)) + (args (rest form))) (case kind (special (dolist (name args) - (unless (symbolp name) - (error "can't declare a non-symbol as SPECIAL: ~S" name)) - (when (constantp name) - (error "can't declare a constant as SPECIAL: ~S" name)) - (with-single-package-locked-error + (unless (symbolp name) + (error "can't declare a non-symbol as SPECIAL: ~S" name)) + (when (constantp name) + (error "can't declare a constant as SPECIAL: ~S" name)) + (with-single-package-locked-error (:symbol name "globally declaring ~A special")) - (clear-info :variable :constant-value name) - (setf (info :variable :kind name) :special))) + (clear-info :variable :constant-value name) + (setf (info :variable :kind name) :special))) (type (if *type-system-initialized* - (let ((type (specifier-type (first args)))) - (dolist (name (rest args)) - (unless (symbolp name) - (error "can't declare TYPE of a non-symbol: ~S" name)) - (with-single-package-locked-error + (let ((type (specifier-type (first args)))) + (dolist (name (rest args)) + (unless (symbolp name) + (error "can't declare TYPE of a non-symbol: ~S" name)) + (with-single-package-locked-error (:symbol name "globally declaring the type of ~A")) - (when (eq (info :variable :where-from name) :declared) - (let ((old-type (info :variable :type name))) - (when (type/= type old-type) - (style-warn "The new TYPE proclamation~% ~S~@ + (when (eq (info :variable :where-from name) :declared) + (let ((old-type (info :variable :type name))) + (when (type/= type old-type) + (style-warn "The new TYPE proclamation~% ~S~@ for ~S does not match the old TYPE~@ proclamation ~S" - type name old-type)))) - (setf (info :variable :type name) type) - (setf (info :variable :where-from name) :declared))) - (push raw-form *queued-proclaims*))) + type name old-type)))) + (setf (info :variable :type name) type) + (setf (info :variable :where-from name) :declared))) + (push raw-form *queued-proclaims*))) (ftype (if *type-system-initialized* - (let ((ctype (specifier-type (first args)))) - (unless (csubtypep ctype (specifier-type 'function)) - (error "not a function type: ~S" (first args))) - (dolist (name (rest args)) - (with-single-package-locked-error + (let ((ctype (specifier-type (first args)))) + (unless (csubtypep ctype (specifier-type 'function)) + (error "not a function type: ~S" (first args))) + (dolist (name (rest args)) + (with-single-package-locked-error (:symbol name "globally declaring the ftype of ~A")) (when (eq (info :function :where-from name) :declared) (let ((old-type (info :function :type name))) @@ -214,59 +214,59 @@ ~S" ctype name old-type)))) - ;; Now references to this function shouldn't be warned - ;; about as undefined, since even if we haven't seen a - ;; definition yet, we know one is planned. - ;; - ;; Other consequences of we-know-you're-a-function-now - ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. - (proclaim-as-fun-name name) - (note-name-defined name :function) + ;; Now references to this function shouldn't be warned + ;; about as undefined, since even if we haven't seen a + ;; definition yet, we know one is planned. + ;; + ;; Other consequences of we-know-you're-a-function-now + ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. + (proclaim-as-fun-name name) + (note-name-defined name :function) - ;; the actual type declaration - (setf (info :function :type name) ctype - (info :function :where-from name) :declared))) - (push raw-form *queued-proclaims*))) + ;; the actual type declaration + (setf (info :function :type name) ctype + (info :function :where-from name) :declared))) + (push raw-form *queued-proclaims*))) (freeze-type (dolist (type args) - (let ((class (specifier-type type))) - (when (typep class 'classoid) - (setf (classoid-state class) :sealed) - (let ((subclasses (classoid-subclasses class))) - (when subclasses - (dohash (subclass layout subclasses) - (declare (ignore layout)) - (setf (classoid-state subclass) :sealed)))))))) + (let ((class (specifier-type type))) + (when (typep class 'classoid) + (setf (classoid-state class) :sealed) + (let ((subclasses (classoid-subclasses class))) + (when subclasses + (dohash (subclass layout subclasses) + (declare (ignore layout)) + (setf (classoid-state subclass) :sealed)))))))) (optimize (setq *policy* (process-optimize-decl form *policy*))) (muffle-conditions (setq *handled-conditions* - (process-muffle-conditions-decl form *handled-conditions*))) + (process-muffle-conditions-decl form *handled-conditions*))) (unmuffle-conditions (setq *handled-conditions* - (process-unmuffle-conditions-decl form *handled-conditions*))) + (process-unmuffle-conditions-decl form *handled-conditions*))) ((disable-package-locks enable-package-locks) (setq *disabled-package-locks* (process-package-lock-decl form *disabled-package-locks*))) ((inline notinline maybe-inline) (dolist (name args) - (proclaim-as-fun-name name) ; since implicitly it is a function - (setf (info :function :inlinep name) - (ecase kind - (inline :inline) - (notinline :notinline) - (maybe-inline :maybe-inline))))) + (proclaim-as-fun-name name) ; since implicitly it is a function + (setf (info :function :inlinep name) + (ecase kind + (inline :inline) + (notinline :notinline) + (maybe-inline :maybe-inline))))) (declaration (dolist (decl args) - (unless (symbolp decl) - (error "In~% ~S~%the declaration to be recognized is not a ~ + (unless (symbolp decl) + (error "In~% ~S~%the declaration to be recognized is not a ~ symbol:~% ~S" - form decl)) - (with-single-package-locked-error + form decl)) + (with-single-package-locked-error (:symbol decl "globally declaring ~A as a declaration proclamation")) - (setf (info :declaration :recognized decl) t))) + (setf (info :declaration :recognized decl) t))) (t (unless (info :declaration :recognized kind) - (compiler-warn "unrecognized declaration ~S" raw-form))))) + (compiler-warn "unrecognized declaration ~S" raw-form))))) #+sb-xc (/show0 "returning from PROCLAIM") (values)) diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index c4b4b86..8d2418e 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -31,49 +31,49 @@ (defun get-operand-info (ref) (declare (type tn-ref ref)) (let* ((arg-p (not (tn-ref-write-p ref))) - (vop (tn-ref-vop ref)) - (info (vop-info vop))) + (vop (tn-ref-vop ref)) + (info (vop-info vop))) (flet ((frob (refs costs load more-cost) - (do ((refs refs (tn-ref-across refs)) - (costs costs (cdr costs)) - (load load (cdr load)) - (n 0 (1+ n))) - ((null costs) - (aver more-cost) - (values arg-p - (+ n - (or (position-in #'tn-ref-across ref refs) - (error "couldn't find REF?")) - 1) - t - more-cost - nil - nil)) - (when (eq refs ref) - (let ((parse (vop-parse-or-lose (vop-info-name info)))) - (multiple-value-bind (ccosts cscs) - (compute-loading-costs - (elt (if arg-p - (vop-parse-args parse) - (vop-parse-results parse)) - n) - arg-p) - - (return - (values arg-p - (1+ n) - nil - (car costs) - (car load) - (not (and (equalp ccosts (car costs)) - (equalp cscs (car load)))))))))))) + (do ((refs refs (tn-ref-across refs)) + (costs costs (cdr costs)) + (load load (cdr load)) + (n 0 (1+ n))) + ((null costs) + (aver more-cost) + (values arg-p + (+ n + (or (position-in #'tn-ref-across ref refs) + (error "couldn't find REF?")) + 1) + t + more-cost + nil + nil)) + (when (eq refs ref) + (let ((parse (vop-parse-or-lose (vop-info-name info)))) + (multiple-value-bind (ccosts cscs) + (compute-loading-costs + (elt (if arg-p + (vop-parse-args parse) + (vop-parse-results parse)) + n) + arg-p) + + (return + (values arg-p + (1+ n) + nil + (car costs) + (car load) + (not (and (equalp ccosts (car costs)) + (equalp cscs (car load)))))))))))) (if arg-p - (frob (vop-args vop) (vop-info-arg-costs info) - (vop-info-arg-load-scs info) - (vop-info-more-arg-costs info)) - (frob (vop-results vop) (vop-info-result-costs info) - (vop-info-result-load-scs info) - (vop-info-more-result-costs info)))))) + (frob (vop-args vop) (vop-info-arg-costs info) + (vop-info-arg-load-scs info) + (vop-info-more-arg-costs info)) + (frob (vop-results vop) (vop-info-result-costs info) + (vop-info-result-load-scs info) + (vop-info-more-result-costs info)))))) ;;; Convert a load-costs vector to the list of SCs allowed by the ;;; operand restriction. @@ -82,7 +82,7 @@ (collect ((res)) (dotimes (i sc-number-limit) (when (eq (svref restr i) t) - (res (svref *backend-sc-numbers* i)))) + (res (svref *backend-sc-numbers* i)))) (res))) ;;; Try to give a helpful error message when REF has no cost specified @@ -90,70 +90,70 @@ (defun bad-costs-error (ref) (declare (type tn-ref ref)) (let* ((tn (tn-ref-tn ref)) - (ptype (tn-primitive-type tn))) + (ptype (tn-primitive-type tn))) (multiple-value-bind (arg-p pos more-p costs load-scs incon) - (get-operand-info ref) + (get-operand-info ref) (collect ((losers)) - (dolist (scn (primitive-type-scs ptype)) - (unless (svref costs scn) - (losers (svref *backend-sc-numbers* scn)))) + (dolist (scn (primitive-type-scs ptype)) + (unless (svref costs scn) + (losers (svref *backend-sc-numbers* scn)))) - (unless (losers) - (error "Representation selection flamed out for no obvious reason.~@ + (unless (losers) + (error "Representation selection flamed out for no obvious reason.~@ Try again after recompiling the VM definition.")) - - (error "~S is not valid as the ~:R ~:[result~;argument~] to the~@ + + (error "~S is not valid as the ~:R ~:[result~;argument~] to the~@ ~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@ ~:[which cannot be coerced or loaded into the allowed SCs:~ ~% ~S~;~*~]~:[~;~@ Current cost info inconsistent with that in effect at compile ~ time. Recompile.~%Compilation order may be incorrect.~]" - tn pos arg-p - (template-name (vop-info (tn-ref-vop ref))) - (primitive-type-name ptype) - (mapcar #'sc-name (losers)) - more-p - (unless more-p - (mapcar #'sc-name (listify-restrictions load-scs))) - incon))))) + tn pos arg-p + (template-name (vop-info (tn-ref-vop ref))) + (primitive-type-name ptype) + (mapcar #'sc-name (losers)) + more-p + (unless more-p + (mapcar #'sc-name (listify-restrictions load-scs))) + incon))))) ;;; Try to give a helpful error message when we fail to do a coercion ;;; for some reason. (defun bad-coerce-error (op) (declare (type tn-ref op)) (let* ((op-tn (tn-ref-tn op)) - (op-sc (tn-sc op-tn)) - (op-scn (sc-number op-sc)) - (ptype (tn-primitive-type op-tn)) - (write-p (tn-ref-write-p op))) + (op-sc (tn-sc op-tn)) + (op-scn (sc-number op-sc)) + (ptype (tn-primitive-type op-tn)) + (write-p (tn-ref-write-p op))) (multiple-value-bind (arg-p pos more-p costs load-scs incon) - (get-operand-info op) + (get-operand-info op) (declare (ignore costs more-p)) (collect ((load-lose) - (no-move-scs) - (move-lose)) - (dotimes (i sc-number-limit) - (let ((i-sc (svref *backend-sc-numbers* i))) - (when (eq (svref load-scs i) t) - (cond ((not (sc-allowed-by-primitive-type i-sc ptype)) - (load-lose i-sc)) - ((not (find-move-vop op-tn write-p i-sc ptype - #'sc-move-vops)) - (let ((vops (if write-p - (svref (sc-move-vops op-sc) i) - (svref (sc-move-vops i-sc) op-scn)))) - (if vops - (dolist (vop vops) (move-lose (template-name vop))) - (no-move-scs i-sc)))) - (t - (error "Representation selection flamed out for no ~ + (no-move-scs) + (move-lose)) + (dotimes (i sc-number-limit) + (let ((i-sc (svref *backend-sc-numbers* i))) + (when (eq (svref load-scs i) t) + (cond ((not (sc-allowed-by-primitive-type i-sc ptype)) + (load-lose i-sc)) + ((not (find-move-vop op-tn write-p i-sc ptype + #'sc-move-vops)) + (let ((vops (if write-p + (svref (sc-move-vops op-sc) i) + (svref (sc-move-vops i-sc) op-scn)))) + (if vops + (dolist (vop vops) (move-lose (template-name vop))) + (no-move-scs i-sc)))) + (t + (error "Representation selection flamed out for no ~ obvious reason.")))))) - - (unless (or (load-lose) (no-move-scs) (move-lose)) - (error "Representation selection flamed out for no obvious reason.~@ + + (unless (or (load-lose) (no-move-scs) (move-lose)) + (error "Representation selection flamed out for no obvious reason.~@ Try again after recompiling the VM definition.")) - (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~ + (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~ ~% ~S~%Primitive type: ~S~@ SC restrictions:~% ~S~@ ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~ @@ -164,21 +164,21 @@ ~:[~;~@ Current cost info inconsistent with that in effect at compile ~ time. Recompile.~%Compilation order may be incorrect.~]" - op-tn pos arg-p - (template-name (vop-info (tn-ref-vop op))) - (primitive-type-name ptype) - (mapcar #'sc-name (listify-restrictions load-scs)) - (mapcar #'sc-name (load-lose)) - (mapcar #'sc-name (no-move-scs)) - (move-lose) - incon))))) + op-tn pos arg-p + (template-name (vop-info (tn-ref-vop op))) + (primitive-type-name ptype) + (mapcar #'sc-name (listify-restrictions load-scs)) + (mapcar #'sc-name (load-lose)) + (mapcar #'sc-name (no-move-scs)) + (move-lose) + incon))))) (defun bad-move-arg-error (val pass) (declare (type tn val pass)) (error "no :MOVE-ARG VOP defined to move ~S (SC ~S) to ~ ~S (SC ~S)" - val (sc-name (tn-sc val)) - pass (sc-name (tn-sc pass)))) + val (sc-name (tn-sc val)) + pass (sc-name (tn-sc pass)))) ;;;; VM consistency checking ;;;; @@ -190,22 +190,22 @@ (dotimes (i sc-number-limit) (let ((sc (svref *backend-sc-numbers* i))) (when sc - (let ((moves (sc-move-funs sc))) - (dolist (const (sc-constant-scs sc)) - (unless (svref moves (sc-number const)) - (warn "no move function defined to load SC ~S from constant ~ + (let ((moves (sc-move-funs sc))) + (dolist (const (sc-constant-scs sc)) + (unless (svref moves (sc-number const)) + (warn "no move function defined to load SC ~S from constant ~ SC ~S" - (sc-name sc) (sc-name const)))) + (sc-name sc) (sc-name const)))) - (dolist (alt (sc-alternate-scs sc)) - (unless (svref moves (sc-number alt)) - (warn "no move function defined to load SC ~S from alternate ~ + (dolist (alt (sc-alternate-scs sc)) + (unless (svref moves (sc-number alt)) + (warn "no move function defined to load SC ~S from alternate ~ SC ~S" - (sc-name sc) (sc-name alt))) - (unless (svref (sc-move-funs alt) i) - (warn "no move function defined to save SC ~S to alternate ~ + (sc-name sc) (sc-name alt))) + (unless (svref (sc-move-funs alt) i) + (warn "no move function defined to save SC ~S to alternate ~ SC ~S" - (sc-name sc) (sc-name alt))))))))) + (sc-name sc) (sc-name alt))))))))) ;;;; representation selection @@ -225,47 +225,47 @@ ;;; chosen (e.g. if it is wired), then we use the appropriate move ;;; costs, otherwise we just ignore the references. (defun add-representation-costs (refs scs costs - ops-slot costs-slot more-costs-slot - write-p) + ops-slot costs-slot more-costs-slot + write-p) (declare (type function ops-slot costs-slot more-costs-slot)) (do ((ref refs (tn-ref-next ref))) ((null ref)) (flet ((add-costs (cost) - (dolist (scn scs) - (let ((res (svref cost scn))) - (unless res - (bad-costs-error ref)) - (incf (svref costs scn) res))))) + (dolist (scn scs) + (let ((res (svref cost scn))) + (unless res + (bad-costs-error ref)) + (incf (svref costs scn) res))))) (let* ((vop (tn-ref-vop ref)) - (info (vop-info vop))) - (unless (find (vop-info-name info) *ignore-cost-vops*) - (case (vop-info-name info) - (move - (let ((rep (tn-sc - (tn-ref-tn - (if write-p - (vop-args vop) - (vop-results vop)))))) - (when rep - (if write-p - (dolist (scn scs) - (let ((res (svref (sc-move-costs - (svref *backend-sc-numbers* scn)) - (sc-number rep)))) - (when res - (incf (svref costs scn) res)))) - (dolist (scn scs) - (let ((res (svref (sc-move-costs rep) scn))) - (when res - (incf (svref costs scn) res)))))))) - (t - (do ((cost (funcall costs-slot info) (cdr cost)) - (op (funcall ops-slot vop) (tn-ref-across op))) - ((null cost) - (add-costs (funcall more-costs-slot info))) - (when (eq op ref) - (add-costs (car cost)) - (return))))))))) + (info (vop-info vop))) + (unless (find (vop-info-name info) *ignore-cost-vops*) + (case (vop-info-name info) + (move + (let ((rep (tn-sc + (tn-ref-tn + (if write-p + (vop-args vop) + (vop-results vop)))))) + (when rep + (if write-p + (dolist (scn scs) + (let ((res (svref (sc-move-costs + (svref *backend-sc-numbers* scn)) + (sc-number rep)))) + (when res + (incf (svref costs scn) res)))) + (dolist (scn scs) + (let ((res (svref (sc-move-costs rep) scn))) + (when res + (incf (svref costs scn) res)))))))) + (t + (do ((cost (funcall costs-slot info) (cdr cost)) + (op (funcall ops-slot vop) (tn-ref-across op))) + ((null cost) + (add-costs (funcall more-costs-slot info))) + (when (eq op ref) + (add-costs (car cost)) + (return))))))))) (values)) ;;; Return the best representation for a normal TN. SCs is a list @@ -278,30 +278,30 @@ ;;; is often not the case for the MOVE VOP. (defun select-tn-representation (tn scs costs) (declare (type tn tn) (type sc-vector costs) - (inline add-representation-costs)) + (inline add-representation-costs)) (dolist (scn scs) (setf (svref costs scn) 0)) (add-representation-costs (tn-reads tn) scs costs - #'vop-args #'vop-info-arg-costs - #'vop-info-more-arg-costs - nil) + #'vop-args #'vop-info-arg-costs + #'vop-info-more-arg-costs + nil) (add-representation-costs (tn-writes tn) scs costs - #'vop-results #'vop-info-result-costs - #'vop-info-more-result-costs - t) + #'vop-results #'vop-info-result-costs + #'vop-info-more-result-costs + t) (let ((min most-positive-fixnum) - (min-scn nil) - (unique nil)) + (min-scn nil) + (unique nil)) (dolist (scn scs) (let ((cost (svref costs scn))) - (cond ((= cost min) - (setf unique nil)) - ((< cost min) - (setq min cost) - (setq min-scn scn) - (setq unique t))))) + (cond ((= cost min) + (setf unique nil)) + ((< cost min) + (setq min cost) + (setq min-scn scn) + (setq unique t))))) (values (svref *backend-sc-numbers* min-scn) unique))) ;;; Prepare for the possibility of a TN being allocated on the number @@ -314,18 +314,18 @@ (do ((ref refs (tn-ref-next ref))) ((null ref)) (let* ((lambda (block-home-lambda - (ir2-block-block - (vop-block (tn-ref-vop ref))))) - (tails (lambda-tail-set lambda))) + (ir2-block-block + (vop-block (tn-ref-vop ref))))) + (tails (lambda-tail-set lambda))) (flet ((frob (fun) - (setf (ir2-physenv-number-stack-p - (physenv-info - (lambda-physenv fun))) - t))) - (frob lambda) - (when tails - (dolist (fun (tail-set-funs tails)) - (frob fun)))))) + (setf (ir2-physenv-number-stack-p + (physenv-info + (lambda-physenv fun))) + t))) + (frob lambda) + (when tails + (dolist (fun (tail-set-funs tails)) + (frob fun)))))) (values)) @@ -335,14 +335,14 @@ (defun get-operand-name (tn arg-p) (declare (type tn tn)) (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn)) - (reads (tn-reads tn)) - (leaf (tn-leaf actual))) + (reads (tn-reads tn)) + (leaf (tn-leaf actual))) (cond ((lambda-var-p leaf) (leaf-source-name leaf)) - ((and (not arg-p) reads - (return-p (vop-node (tn-ref-vop reads)))) - "") - (t - nil)))) + ((and (not arg-p) reads + (return-p (vop-node (tn-ref-vop reads)))) + "") + (t + nil)))) ;;; If policy indicates, give an efficiency note for doing the ;;; coercion VOP, where OP is the operand we are coercing for and @@ -350,35 +350,35 @@ (defun maybe-emit-coerce-efficiency-note (vop op dest-tn) (declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn)) (let* ((note (or (template-note vop) (template-name vop))) - (cost (template-cost vop)) - (op-vop (tn-ref-vop op)) - (op-node (vop-node op-vop)) - (op-tn (tn-ref-tn op)) - (*compiler-error-context* op-node)) + (cost (template-cost vop)) + (op-vop (tn-ref-vop op)) + (op-node (vop-node op-vop)) + (op-tn (tn-ref-tn op)) + (*compiler-error-context* op-node)) (cond ((eq (tn-kind op-tn) :constant)) - ((policy op-node (and (<= speed inhibit-warnings) - (<= space inhibit-warnings)))) - ((member (template-name (vop-info op-vop)) *suppress-note-vops*)) - ((null dest-tn) - (let* ((op-info (vop-info op-vop)) - (op-note (or (template-note op-info) - (template-name op-info))) - (arg-p (not (tn-ref-write-p op))) - (name (get-operand-name op-tn arg-p)) - (pos (1+ (or (position-in #'tn-ref-across op - (if arg-p - (vop-args op-vop) - (vop-results op-vop))) - (error "couldn't find op? bug!"))))) - (compiler-notify - "doing ~A (cost ~W)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~ + ((policy op-node (and (<= speed inhibit-warnings) + (<= space inhibit-warnings)))) + ((member (template-name (vop-info op-vop)) *suppress-note-vops*)) + ((null dest-tn) + (let* ((op-info (vop-info op-vop)) + (op-note (or (template-note op-info) + (template-name op-info))) + (arg-p (not (tn-ref-write-p op))) + (name (get-operand-name op-tn arg-p)) + (pos (1+ (or (position-in #'tn-ref-across op + (if arg-p + (vop-args op-vop) + (vop-results op-vop))) + (error "couldn't find op? bug!"))))) + (compiler-notify + "doing ~A (cost ~W)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~ the ~:R ~:[result~;argument~] of ~A" - note cost name arg-p name - pos arg-p op-note))) - (t - (compiler-notify "doing ~A (cost ~W)~@[ from ~S~]~@[ to ~S~]" - note cost (get-operand-name op-tn t) - (get-operand-name dest-tn nil))))) + note cost name arg-p name + pos arg-p op-note))) + (t + (compiler-notify "doing ~A (cost ~W)~@[ from ~S~]~@[ to ~S~]" + note cost (get-operand-name op-tn t) + (get-operand-name dest-tn nil))))) (values)) ;;; Find a move VOP to move from the operand OP-TN to some other @@ -394,29 +394,29 @@ ;;; operand has the type info. (defun find-move-vop (op-tn write-p other-sc other-ptype slot) (declare (type tn op-tn) (type sc other-sc) - (type primitive-type other-ptype) - (type function slot)) + (type primitive-type other-ptype) + (type function slot)) (let* ((op-sc (tn-sc op-tn)) - (op-scn (sc-number op-sc)) - (other-scn (sc-number other-sc)) - (any-ptype *backend-t-primitive-type*) - (op-ptype (tn-primitive-type op-tn))) + (op-scn (sc-number op-sc)) + (other-scn (sc-number other-sc)) + (any-ptype *backend-t-primitive-type*) + (op-ptype (tn-primitive-type op-tn))) (let ((other-ptype (if (eq other-ptype any-ptype) op-ptype other-ptype)) - (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype))) + (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype))) (dolist (info (if write-p - (svref (funcall slot op-sc) other-scn) - (svref (funcall slot other-sc) op-scn)) - nil) - (when (and (operand-restriction-ok - (first (template-arg-types info)) - (if write-p other-ptype op-ptype) - :tn op-tn :t-ok nil) - (operand-restriction-ok - (first (template-result-types info)) - (if write-p op-ptype other-ptype) - :t-ok nil)) - (return info)))))) - + (svref (funcall slot op-sc) other-scn) + (svref (funcall slot other-sc) op-scn)) + nil) + (when (and (operand-restriction-ok + (first (template-arg-types info)) + (if write-p other-ptype op-ptype) + :tn op-tn :t-ok nil) + (operand-restriction-ok + (first (template-result-types info)) + (if write-p op-ptype other-ptype) + :t-ok nil)) + (return info)))))) + ;;; Emit a coercion VOP for OP BEFORE the specifed VOP or die trying. ;;; SCS is the operand's LOAD-SCS vector, which we use to determine ;;; what SCs the VOP will accept. We pick any acceptable coerce VOP, @@ -440,46 +440,46 @@ ;;; move; we just change to the right kind of TN. (defun emit-coerce-vop (op dest-tn scs before) (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before) - (type (or tn null) dest-tn)) + (type (or tn null) dest-tn)) (let* ((op-tn (tn-ref-tn op)) - (ptype (tn-primitive-type op-tn)) - (write-p (tn-ref-write-p op)) - (vop (tn-ref-vop op)) - (node (vop-node vop)) - (block (vop-block vop))) + (ptype (tn-primitive-type op-tn)) + (write-p (tn-ref-write-p op)) + (vop (tn-ref-vop op)) + (node (vop-node vop)) + (block (vop-block vop))) (flet ((check-sc (scn sc) - (when (sc-allowed-by-primitive-type sc ptype) - (let ((res (find-move-vop op-tn write-p sc ptype - #'sc-move-vops))) - (when res - (when (>= (vop-info-cost res) - *efficiency-note-cost-threshold*) - (maybe-emit-coerce-efficiency-note res op dest-tn)) - (let ((temp (make-representation-tn ptype scn))) - (change-tn-ref-tn op temp) - (cond - ((not write-p) - (emit-move-template node block res op-tn temp before)) - ((and (null (tn-reads op-tn)) - (eq (tn-kind op-tn) :normal))) - (t - (emit-move-template node block res temp op-tn - before)))) - t))))) + (when (sc-allowed-by-primitive-type sc ptype) + (let ((res (find-move-vop op-tn write-p sc ptype + #'sc-move-vops))) + (when res + (when (>= (vop-info-cost res) + *efficiency-note-cost-threshold*) + (maybe-emit-coerce-efficiency-note res op dest-tn)) + (let ((temp (make-representation-tn ptype scn))) + (change-tn-ref-tn op temp) + (cond + ((not write-p) + (emit-move-template node block res op-tn temp before)) + ((and (null (tn-reads op-tn)) + (eq (tn-kind op-tn) :normal))) + (t + (emit-move-template node block res temp op-tn + before)))) + t))))) ;; Search the non-stack load SCs first. (dotimes (scn sc-number-limit) - (let ((sc (svref *backend-sc-numbers* scn))) - (when (and (eq (svref scs scn) t) - (not (eq (sb-kind (sc-sb sc)) :unbounded)) - (check-sc scn sc)) - (return-from emit-coerce-vop)))) + (let ((sc (svref *backend-sc-numbers* scn))) + (when (and (eq (svref scs scn) t) + (not (eq (sb-kind (sc-sb sc)) :unbounded)) + (check-sc scn sc)) + (return-from emit-coerce-vop)))) ;; Search the stack SCs if the above failed. (dotimes (scn sc-number-limit (bad-coerce-error op)) - (let ((sc (svref *backend-sc-numbers* scn))) - (when (and (eq (svref scs scn) t) - (eq (sb-kind (sc-sb sc)) :unbounded) - (check-sc scn sc)) - (return))))))) + (let ((sc (svref *backend-sc-numbers* scn))) + (when (and (eq (svref scs scn) t) + (eq (sb-kind (sc-sb sc)) :unbounded) + (check-sc scn sc)) + (return))))))) ;;; Scan some operands and call EMIT-COERCE-VOP on any for which we ;;; can't load the operand. The coerce VOP is inserted Before the @@ -489,12 +489,12 @@ #!-sb-fluid (declaim (inline coerce-some-operands)) (defun coerce-some-operands (ops dest-tn load-scs before) (declare (type (or tn-ref null) ops) (list load-scs) - (type (or tn null) dest-tn) (type (or vop null) before)) + (type (or tn null) dest-tn) (type (or vop null) before)) (do ((op ops (tn-ref-across op)) (scs load-scs (cdr scs))) ((null scs)) (unless (svref (car scs) - (sc-number (tn-sc (tn-ref-tn op)))) + (sc-number (tn-sc (tn-ref-tn op)))) (emit-coerce-vop op dest-tn (car scs) before))) (values)) @@ -504,7 +504,7 @@ (let ((info (vop-info vop))) (coerce-some-operands (vop-args vop) nil (vop-info-arg-load-scs info) vop) (coerce-some-operands (vop-results vop) nil (vop-info-result-load-scs info) - (vop-next vop))) + (vop-next vop))) (values)) ;;; Iterate over the more operands to a call VOP, emitting move-arg @@ -515,62 +515,62 @@ ;;; passing locations are written between A-F and call.) (defun emit-arg-moves (vop) (let* ((info (vop-info vop)) - (node (vop-node vop)) - (block (vop-block vop)) - (how (vop-info-move-args info)) - (args (vop-args vop)) - (fp-tn (tn-ref-tn args)) - (nfp-tn (if (eq how :local-call) - (tn-ref-tn (tn-ref-across args)) - nil)) - (pass-locs (first (vop-codegen-info vop))) - (prev (vop-prev vop))) + (node (vop-node vop)) + (block (vop-block vop)) + (how (vop-info-move-args info)) + (args (vop-args vop)) + (fp-tn (tn-ref-tn args)) + (nfp-tn (if (eq how :local-call) + (tn-ref-tn (tn-ref-across args)) + nil)) + (pass-locs (first (vop-codegen-info vop))) + (prev (vop-prev vop))) (do ((val (do ((arg args (tn-ref-across arg)) - (req (template-arg-types info) (cdr req))) - ((null req) arg)) - (tn-ref-across val)) - (pass pass-locs (cdr pass))) - ((null val) - (aver (null pass))) + (req (template-arg-types info) (cdr req))) + ((null req) arg)) + (tn-ref-across val)) + (pass pass-locs (cdr pass))) + ((null val) + (aver (null pass))) (let* ((val-tn (tn-ref-tn val)) - (pass-tn (first pass)) - (pass-sc (tn-sc pass-tn)) - (res (find-move-vop val-tn nil pass-sc - (tn-primitive-type pass-tn) - #'sc-move-arg-vops))) - (unless res - (bad-move-arg-error val-tn pass-tn)) - - (change-tn-ref-tn val pass-tn) - (let* ((this-fp - (cond ((not (sc-number-stack-p pass-sc)) fp-tn) - (nfp-tn) - (t - (aver (eq how :known-return)) - (setq nfp-tn (make-number-stack-pointer-tn)) - (setf (tn-sc nfp-tn) - (svref *backend-sc-numbers* - (first (primitive-type-scs - (tn-primitive-type nfp-tn))))) - (emit-context-template - node block - (template-or-lose 'compute-old-nfp) - nfp-tn vop) - (aver (not (sc-number-stack-p (tn-sc nfp-tn)))) - nfp-tn))) - (new (emit-move-arg-template node block res val-tn this-fp - pass-tn vop)) - (after - (cond ((eq how :local-call) - (aver (eq (vop-info-name (vop-info prev)) - 'allocate-frame)) - prev) - (prev (vop-next prev)) - (t - (ir2-block-start-vop block))))) - (coerce-some-operands (vop-args new) pass-tn - (vop-info-arg-load-scs res) - after))))) + (pass-tn (first pass)) + (pass-sc (tn-sc pass-tn)) + (res (find-move-vop val-tn nil pass-sc + (tn-primitive-type pass-tn) + #'sc-move-arg-vops))) + (unless res + (bad-move-arg-error val-tn pass-tn)) + + (change-tn-ref-tn val pass-tn) + (let* ((this-fp + (cond ((not (sc-number-stack-p pass-sc)) fp-tn) + (nfp-tn) + (t + (aver (eq how :known-return)) + (setq nfp-tn (make-number-stack-pointer-tn)) + (setf (tn-sc nfp-tn) + (svref *backend-sc-numbers* + (first (primitive-type-scs + (tn-primitive-type nfp-tn))))) + (emit-context-template + node block + (template-or-lose 'compute-old-nfp) + nfp-tn vop) + (aver (not (sc-number-stack-p (tn-sc nfp-tn)))) + nfp-tn))) + (new (emit-move-arg-template node block res val-tn this-fp + pass-tn vop)) + (after + (cond ((eq how :local-call) + (aver (eq (vop-info-name (vop-info prev)) + 'allocate-frame)) + prev) + (prev (vop-next prev)) + (t + (ir2-block-start-vop block))))) + (coerce-some-operands (vop-args new) pass-tn + (vop-info-arg-load-scs res) + after))))) (values)) ;;; Scan the IR2 looking for move operations that need to be replaced @@ -581,34 +581,34 @@ (defun emit-moves-and-coercions (block) (declare (type ir2-block block)) (do ((vop (ir2-block-start-vop block) - (vop-next vop))) + (vop-next vop))) ((null vop)) (let ((info (vop-info vop)) - (node (vop-node vop)) - (block (vop-block vop))) + (node (vop-node vop)) + (block (vop-block vop))) (cond ((eq (vop-info-name info) 'move) - (let* ((args (vop-args vop)) - (x (tn-ref-tn args)) - (y (tn-ref-tn (vop-results vop))) - (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y) - #'sc-move-vops))) - (cond ((and (null (tn-reads y)) - (eq (tn-kind y) :normal)) - (delete-vop vop)) - ((eq res info)) - (res - (when (>= (vop-info-cost res) - *efficiency-note-cost-threshold*) - (maybe-emit-coerce-efficiency-note res args y)) - (emit-move-template node block res x y vop) - (delete-vop vop)) - (t - (coerce-vop-operands vop))))) + (let* ((args (vop-args vop)) + (x (tn-ref-tn args)) + (y (tn-ref-tn (vop-results vop))) + (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y) + #'sc-move-vops))) + (cond ((and (null (tn-reads y)) + (eq (tn-kind y) :normal)) + (delete-vop vop)) + ((eq res info)) + (res + (when (>= (vop-info-cost res) + *efficiency-note-cost-threshold*) + (maybe-emit-coerce-efficiency-note res args y)) + (emit-move-template node block res x y vop) + (delete-vop vop)) + (t + (coerce-vop-operands vop))))) ((vop-info-move-args info) - (emit-arg-moves vop)) + (emit-arg-moves vop)) (t - (coerce-vop-operands vop)))))) + (coerce-vop-operands vop)))))) ;;; If TN is in a number stack SC, make all the right annotations. ;;; Note that this should be called after TN has been referenced, @@ -617,8 +617,8 @@ (defun note-if-number-stack (tn 2comp restricted) (declare (type tn tn) (type ir2-component 2comp)) (when (if restricted - (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack) - (sc-number-stack-p (tn-sc tn))) + (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack) + (sc-number-stack-p (tn-sc tn))) (unless (ir2-component-nfp 2comp) (setf (ir2-component-nfp 2comp) (make-nfp-tn))) (note-number-stack-tn (tn-reads tn)) @@ -636,48 +636,48 @@ ;;; environments may be introduced by MOVE-ARG insertion. (defun select-representations (component) (let ((costs (make-array sc-number-limit)) - (2comp (component-info component))) + (2comp (component-info component))) ;; First pass; only allocate SCs where there is a distinct choice. (do ((tn (ir2-component-normal-tns 2comp) - (tn-next tn))) - ((null tn)) + (tn-next tn))) + ((null tn)) (aver (tn-primitive-type tn)) (unless (tn-sc tn) - (let* ((scs (primitive-type-scs (tn-primitive-type tn)))) - (cond ((rest scs) - (multiple-value-bind (sc unique) - (select-tn-representation tn scs costs) - (when unique - (setf (tn-sc tn) sc)))) - (t - (setf (tn-sc tn) - (svref *backend-sc-numbers* (first scs)))))))) + (let* ((scs (primitive-type-scs (tn-primitive-type tn)))) + (cond ((rest scs) + (multiple-value-bind (sc unique) + (select-tn-representation tn scs costs) + (when unique + (setf (tn-sc tn) sc)))) + (t + (setf (tn-sc tn) + (svref *backend-sc-numbers* (first scs)))))))) (do ((tn (ir2-component-normal-tns 2comp) - (tn-next tn))) - ((null tn)) + (tn-next tn))) + ((null tn)) (aver (tn-primitive-type tn)) (unless (tn-sc tn) - (let* ((scs (primitive-type-scs (tn-primitive-type tn))) - (sc (if (rest scs) - (select-tn-representation tn scs costs) - (svref *backend-sc-numbers* (first scs))))) - (aver sc) - (setf (tn-sc tn) sc)))) + (let* ((scs (primitive-type-scs (tn-primitive-type tn))) + (sc (if (rest scs) + (select-tn-representation tn scs costs) + (svref *backend-sc-numbers* (first scs))))) + (aver sc) + (setf (tn-sc tn) sc)))) (do ((alias (ir2-component-alias-tns 2comp) - (tn-next alias))) - ((null alias)) + (tn-next alias))) + ((null alias)) (setf (tn-sc alias) (tn-sc (tn-save-tn alias)))) (do-ir2-blocks (block component) (emit-moves-and-coercions block)) (macrolet ((frob (slot restricted) - `(do ((tn (,slot 2comp) (tn-next tn))) - ((null tn)) - (note-if-number-stack tn 2comp ,restricted)))) + `(do ((tn (,slot 2comp) (tn-next tn))) + ((null tn)) + (note-if-number-stack tn 2comp ,restricted)))) (frob ir2-component-normal-tns nil) (frob ir2-component-wired-tns t) (frob ir2-component-restricted-tns t))) diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp index 178e61e..cf84c28 100644 --- a/src/compiler/saptran.lisp +++ b/src/compiler/saptran.lisp @@ -20,29 +20,29 @@ (give-up-ir1-transform))) (deftransform foreign-symbol-sap ((symbol &optional datap) - (simple-string &optional boolean)) + (simple-string &optional boolean)) #!-linkage-table (if (null datap) - (give-up-ir1-transform) - `(foreign-symbol-sap symbol)) + (give-up-ir1-transform) + `(foreign-symbol-sap symbol)) #!+linkage-table (if (and (constant-lvar-p symbol) (constant-lvar-p datap)) - (let ((name (lvar-value symbol)) - (datap (lvar-value datap))) - (if (or #+sb-xc-host t ; only static symbols on host + (let ((name (lvar-value symbol)) + (datap (lvar-value datap))) + (if (or #+sb-xc-host t ; only static symbols on host (not datap) - (find-foreign-symbol-in-table name *static-foreign-symbols*)) - `(foreign-symbol-sap ,name) ; VOP - `(foreign-symbol-dataref-sap ,name))) ; VOP - (give-up-ir1-transform))) + (find-foreign-symbol-in-table name *static-foreign-symbols*)) + `(foreign-symbol-sap ,name) ; VOP + `(foreign-symbol-dataref-sap ,name))) ; VOP + (give-up-ir1-transform))) (defknown (sap< sap<= sap= sap>= sap>) - (system-area-pointer system-area-pointer) boolean + (system-area-pointer system-area-pointer) boolean (movable flushable)) (defknown sap+ (system-area-pointer integer) system-area-pointer (movable flushable)) -(defknown sap- (system-area-pointer system-area-pointer) +(defknown sap- (system-area-pointer system-area-pointer) (signed-byte #.sb!vm::n-word-bits) (movable flushable)) @@ -134,14 +134,14 @@ (flushable)) (defknown %set-sap-ref-single - (system-area-pointer fixnum single-float) single-float + (system-area-pointer fixnum single-float) single-float ()) (defknown %set-sap-ref-double - (system-area-pointer fixnum double-float) double-float + (system-area-pointer fixnum double-float) double-float ()) #!+long-float (defknown %set-sap-ref-long - (system-area-pointer fixnum long-float) long-float + (system-area-pointer fixnum long-float) long-float ()) ;;;; transforms for converting sap relation operators @@ -159,12 +159,12 @@ (deftransform sap+ ((sap offset)) (cond ((and (constant-lvar-p offset) - (eql (lvar-value offset) 0)) - 'sap) - (t - (extract-fun-args sap 'sap+ 2) - '(lambda (sap offset1 offset2) - (sap+ sap (+ offset1 offset2)))))) + (eql (lvar-value offset) 0)) + 'sap) + (t + (extract-fun-args sap 'sap+ 2) + '(lambda (sap offset1 offset2) + (sap+ sap (+ offset1 offset2)))))) (macrolet ((def (fun) `(deftransform ,fun ((sap offset) * *) @@ -201,10 +201,10 @@ #!+long-float (def %set-sap-ref-long)) (macrolet ((def (fun args 32-bit 64-bit) - `(deftransform ,fun (,args) - (ecase sb!vm::n-word-bits - (32 '(,32-bit ,@args)) - (64 '(,64-bit ,@args)))))) + `(deftransform ,fun (,args) + (ecase sb!vm::n-word-bits + (32 '(,32-bit ,@args)) + (64 '(,64-bit ,@args)))))) (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64) (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64) (def %set-sap-ref-word (sap offset value) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index a7a33b7..4a75395 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -15,42 +15,42 @@ (defun mapfoo-transform (fn arglists accumulate take-car) (collect ((do-clauses) - (args-to-fn) - (tests)) + (args-to-fn) + (tests)) (let ((n-first (gensym))) (dolist (a (if accumulate - arglists - `(,n-first ,@(rest arglists)))) - (let ((v (gensym))) - (do-clauses `(,v ,a (cdr ,v))) - (tests `(endp ,v)) - (args-to-fn (if take-car `(car ,v) v)))) + arglists + `(,n-first ,@(rest arglists)))) + (let ((v (gensym))) + (do-clauses `(,v ,a (cdr ,v))) + (tests `(endp ,v)) + (args-to-fn (if take-car `(car ,v) v)))) (let* ((fn-sym (gensym)) ; for ONCE-ONLY-ish purposes - (call `(funcall ,fn-sym . ,(args-to-fn))) - (endtest `(or ,@(tests)))) - (ecase accumulate - (:nconc - (let ((temp (gensym)) - (map-result (gensym))) - `(let ((,fn-sym ,fn) - (,map-result (list nil))) - (do-anonymous ((,temp ,map-result) . ,(do-clauses)) - (,endtest (cdr ,map-result)) - (setq ,temp (last (nconc ,temp ,call))))))) - (:list - (let ((temp (gensym)) - (map-result (gensym))) - `(let ((,fn-sym ,fn) - (,map-result (list nil))) - (do-anonymous ((,temp ,map-result) . ,(do-clauses)) - (,endtest (truly-the list (cdr ,map-result))) - (rplacd ,temp (setq ,temp (list ,call))))))) - ((nil) - `(let ((,fn-sym ,fn) - (,n-first ,(first arglists))) - (do-anonymous ,(do-clauses) - (,endtest (truly-the list ,n-first)) + (call `(funcall ,fn-sym . ,(args-to-fn))) + (endtest `(or ,@(tests)))) + (ecase accumulate + (:nconc + (let ((temp (gensym)) + (map-result (gensym))) + `(let ((,fn-sym ,fn) + (,map-result (list nil))) + (do-anonymous ((,temp ,map-result) . ,(do-clauses)) + (,endtest (cdr ,map-result)) + (setq ,temp (last (nconc ,temp ,call))))))) + (:list + (let ((temp (gensym)) + (map-result (gensym))) + `(let ((,fn-sym ,fn) + (,map-result (list nil))) + (do-anonymous ((,temp ,map-result) . ,(do-clauses)) + (,endtest (truly-the list (cdr ,map-result))) + (rplacd ,temp (setq ,temp (list ,call))))))) + ((nil) + `(let ((,fn-sym ,fn) + (,n-first ,(first arglists))) + (do-anonymous ,(do-clauses) + (,endtest (truly-the list ,n-first)) ,call)))))))) (define-source-transform mapc (function list &rest more-lists) @@ -78,48 +78,48 @@ ;;; TRULY-THE for the most specific type we can determine. (deftransform map ((result-type-arg fun seq &rest seqs) * * :node node) (let* ((seq-names (make-gensym-list (1+ (length seqs)))) - (bare `(%map result-type-arg fun ,@seq-names)) - (constant-result-type-arg-p (constant-lvar-p result-type-arg)) - ;; what we know about the type of the result. (Note that the - ;; "result type" argument is not necessarily the type of the - ;; result, since NIL means the result has NULL type.) - (result-type (if (not constant-result-type-arg-p) - 'consed-sequence - (let ((result-type-arg-value - (lvar-value result-type-arg))) - (if (null result-type-arg-value) - 'null - result-type-arg-value))))) + (bare `(%map result-type-arg fun ,@seq-names)) + (constant-result-type-arg-p (constant-lvar-p result-type-arg)) + ;; what we know about the type of the result. (Note that the + ;; "result type" argument is not necessarily the type of the + ;; result, since NIL means the result has NULL type.) + (result-type (if (not constant-result-type-arg-p) + 'consed-sequence + (let ((result-type-arg-value + (lvar-value result-type-arg))) + (if (null result-type-arg-value) + 'null + result-type-arg-value))))) `(lambda (result-type-arg fun ,@seq-names) (truly-the ,result-type - ,(cond ((policy node (< safety 3)) - ;; ANSI requires the length-related type check only - ;; when the SAFETY quality is 3... in other cases, we - ;; skip it, because it could be expensive. - bare) - ((not constant-result-type-arg-p) - `(sequence-of-checked-length-given-type ,bare - result-type-arg)) - (t - (let ((result-ctype (ir1-transform-specifier-type - result-type))) - (if (array-type-p result-ctype) - (let ((dims (array-type-dimensions result-ctype))) - (unless (and (listp dims) (= (length dims) 1)) - (give-up-ir1-transform "invalid sequence type")) - (let ((dim (first dims))) - (if (eq dim '*) - bare - `(vector-of-checked-length-given-length ,bare - ,dim)))) - ;; FIXME: this is wrong, as not all subtypes of - ;; VECTOR are ARRAY-TYPEs [consider, for - ;; example, (OR (VECTOR T 3) (VECTOR T - ;; 4))]. However, it's difficult to see what we - ;; should put here... maybe we should - ;; GIVE-UP-IR1-TRANSFORM if the type is a - ;; subtype of VECTOR but not an ARRAY-TYPE? - bare)))))))) + ,(cond ((policy node (< safety 3)) + ;; ANSI requires the length-related type check only + ;; when the SAFETY quality is 3... in other cases, we + ;; skip it, because it could be expensive. + bare) + ((not constant-result-type-arg-p) + `(sequence-of-checked-length-given-type ,bare + result-type-arg)) + (t + (let ((result-ctype (ir1-transform-specifier-type + result-type))) + (if (array-type-p result-ctype) + (let ((dims (array-type-dimensions result-ctype))) + (unless (and (listp dims) (= (length dims) 1)) + (give-up-ir1-transform "invalid sequence type")) + (let ((dim (first dims))) + (if (eq dim '*) + bare + `(vector-of-checked-length-given-length ,bare + ,dim)))) + ;; FIXME: this is wrong, as not all subtypes of + ;; VECTOR are ARRAY-TYPEs [consider, for + ;; example, (OR (VECTOR T 3) (VECTOR T + ;; 4))]. However, it's difficult to see what we + ;; should put here... maybe we should + ;; GIVE-UP-IR1-TRANSFORM if the type is a + ;; subtype of VECTOR but not an ARRAY-TYPE? + bare)))))))) ;;; Return a DO loop, mapping a function FUN to elements of ;;; sequences. SEQS is a list of lvars, SEQ-NAMES - list of variables, @@ -131,7 +131,7 @@ (declare (type list seqs seq-names) (type symbol into)) (collect ((bindings) - (declarations) + (declarations) (vector-lengths) (tests) (places)) @@ -146,7 +146,7 @@ for seq-name in seq-names for type = (lvar-type seq) do (cond ((csubtypep type (specifier-type 'list)) - (with-unique-names (index) + (with-unique-names (index) (bindings `(,index ,seq-name (cdr ,index))) (declarations `(type list ,index)) (places `(car ,index)) @@ -182,61 +182,61 @@ ;;; the reader, because the code is complicated enough already and I ;;; don't happen to need that functionality right now. -- WHN 20000410 (deftransform %map ((result-type fun seq &rest seqs) * * - :policy (>= speed space)) + :policy (>= speed space)) "open code" (unless (constant-lvar-p result-type) (give-up-ir1-transform "RESULT-TYPE argument not constant")) (labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true - (fn-1subtypep (fn x y) - (multiple-value-bind (subtype-p valid-p) (funcall fn x y) - (if valid-p - subtype-p - (give-up-ir1-transform - "can't analyze sequence type relationship")))) - (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y))) + (fn-1subtypep (fn x y) + (multiple-value-bind (subtype-p valid-p) (funcall fn x y) + (if valid-p + subtype-p + (give-up-ir1-transform + "can't analyze sequence type relationship")))) + (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y))) (let* ((result-type-value (lvar-value result-type)) - (result-supertype (cond ((null result-type-value) 'null) - ((1subtypep result-type-value 'vector) - 'vector) - ((1subtypep result-type-value 'list) - 'list) - (t - (give-up-ir1-transform - "can't determine result type"))))) + (result-supertype (cond ((null result-type-value) 'null) + ((1subtypep result-type-value 'vector) + 'vector) + ((1subtypep result-type-value 'list) + 'list) + (t + (give-up-ir1-transform + "can't determine result type"))))) (cond ((and result-type-value (null seqs)) - ;; The consing arity-1 cases can be implemented - ;; reasonably efficiently as function calls, and the cost - ;; of consing should be significantly larger than - ;; function call overhead, so we always compile these - ;; cases as full calls regardless of speed-versus-space - ;; optimization policy. - (cond ((subtypep result-type-value 'list) - '(%map-to-list-arity-1 fun seq)) - ( ;; (This one can be inefficient due to COERCE, but - ;; the current open-coded implementation has the - ;; same problem.) - (subtypep result-type-value 'vector) - `(coerce (%map-to-simple-vector-arity-1 fun seq) - ',result-type-value)) - (t (bug "impossible (?) sequence type")))) - (t - (let* ((seqs (cons seq seqs)) - (seq-args (make-gensym-list (length seqs)))) - (multiple-value-bind (push-dacc result) - (ecase result-supertype - (null (values nil nil)) - (list (values `(push funcall-result acc) + ;; The consing arity-1 cases can be implemented + ;; reasonably efficiently as function calls, and the cost + ;; of consing should be significantly larger than + ;; function call overhead, so we always compile these + ;; cases as full calls regardless of speed-versus-space + ;; optimization policy. + (cond ((subtypep result-type-value 'list) + '(%map-to-list-arity-1 fun seq)) + ( ;; (This one can be inefficient due to COERCE, but + ;; the current open-coded implementation has the + ;; same problem.) + (subtypep result-type-value 'vector) + `(coerce (%map-to-simple-vector-arity-1 fun seq) + ',result-type-value)) + (t (bug "impossible (?) sequence type")))) + (t + (let* ((seqs (cons seq seqs)) + (seq-args (make-gensym-list (length seqs)))) + (multiple-value-bind (push-dacc result) + (ecase result-supertype + (null (values nil nil)) + (list (values `(push funcall-result acc) `(nreverse acc))) - (vector (values `(push funcall-result acc) - `(coerce (nreverse acc) - ',result-type-value)))) - ;; (We use the same idiom, of returning a LAMBDA from - ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for - ;; FUNCALL and ALIEN-FUNCALL, and for the same - ;; reason: we need to get the runtime values of each - ;; of the &REST vars.) - `(lambda (result-type fun ,@seq-args) - (declare (ignore result-type)) + (vector (values `(push funcall-result acc) + `(coerce (nreverse acc) + ',result-type-value)))) + ;; (We use the same idiom, of returning a LAMBDA from + ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for + ;; FUNCALL and ALIEN-FUNCALL, and for the same + ;; reason: we need to get the runtime values of each + ;; of the &REST vars.) + `(lambda (result-type fun ,@seq-args) + (declare (ignore result-type)) (let ((fun (%coerce-callable-to-fun fun)) (acc nil)) (declare (type list acc)) @@ -281,18 +281,18 @@ '(setf (car (nthcdr i s)) v)) (deftransform %check-vector-sequence-bounds ((vector start end) - (vector * *) * - :node node) + (vector * *) * + :node node) (if (policy node (< safety speed)) '(or end (length vector)) '(let ((length (length vector))) - (if (<= 0 start (or end length) length) - (or end length) - (sb!impl::signal-bounding-indices-bad-error vector start end))))) + (if (<= 0 start (or end length) length) + (or end length) + (sb!impl::signal-bounding-indices-bad-error vector start end))))) (macrolet ((def (name) `(deftransform ,name ((e l &key (test #'eql)) * * - :node node) + :node node) (unless (constant-lvar-p l) (give-up-ir1-transform)) @@ -343,33 +343,33 @@ (deftransform delete-if ((pred list) (t list)) "open code" '(do ((x list (cdr x)) - (splice '())) + (splice '())) ((endp x) list) (cond ((funcall pred (car x)) - (if (null splice) - (setq list (cdr x)) - (rplacd splice (cdr x)))) - (t (setq splice x))))) + (if (null splice) + (setq list (cdr x)) + (rplacd splice (cdr x)))) + (t (setq splice x))))) (deftransform fill ((seq item &key (start 0) (end (length seq))) - (vector t &key (:start t) (:end index)) - * - :policy (> speed space)) + (vector t &key (:start t) (:end index)) + * + :policy (> speed space)) "open code" (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) - (values + (values `(with-array-data ((data seq) - (start start) - (end end)) + (start start) + (end end)) (declare (type (simple-array ,element-type 1) data)) (declare (type fixnum start end)) (do ((i start (1+ i))) - ((= i end) seq) - (declare (type index i)) - ;; WITH-ARRAY-DATA did our range checks once and for all, so - ;; it'd be wasteful to check again on every AREF... - (declare (optimize (safety 0))) - (setf (aref data i) item))) + ((= i end) seq) + (declare (type index i)) + ;; WITH-ARRAY-DATA did our range checks once and for all, so + ;; it'd be wasteful to check again on every AREF... + (declare (optimize (safety 0))) + (setf (aref data i) item))) ;; ... though we still need to check that the new element can fit ;; into the vector in safe code. -- CSR, 2002-07-05 `((declare (type ,element-type item)))))) @@ -382,11 +382,11 @@ (declare (type lvar lvar) (list names)) (let ((use (lvar-uses lvar))) (and (ref-p use) - (let ((leaf (ref-leaf use))) - (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function) - (not (null (member (leaf-source-name leaf) names - :test #'equal)))))))) + (let ((leaf (ref-leaf use))) + (and (global-var-p leaf) + (eq (global-var-kind leaf) :global-function) + (not (null (member (leaf-source-name leaf) names + :test #'equal)))))))) ;;; If LVAR is a constant lvar, the return the constant value. If it ;;; is null, then return default, otherwise quietly give up the IR1 @@ -396,10 +396,10 @@ (defun constant-value-or-lose (lvar &optional default) (declare (type (or lvar null) lvar)) (cond ((not lvar) default) - ((constant-lvar-p lvar) - (lvar-value lvar)) - (t - (give-up-ir1-transform)))) + ((constant-lvar-p lvar) + (lvar-value lvar)) + (t + (give-up-ir1-transform)))) ;;; FIXME: Why is this code commented out? (Why *was* it commented ;;; out? We inherited this situation from cmucl-2.4.8, with no @@ -410,7 +410,7 @@ ;;; the argument (which should be referenced in any expansion), and ;;; the continuation for that argument (or NIL if unsupplied.) (defstruct (arg (:constructor %make-arg (name cont)) - (:copier nil)) + (:copier nil)) (name nil :type symbol) (cont nil :type (or continuation null))) (defmacro make-arg (name) @@ -431,10 +431,10 @@ (declare (type (or arg null) arg)) (if (and arg (arg-cont arg)) (let ((cont (arg-cont arg))) - (unless (constant-continuation-p cont) - (give-up-ir1-transform "Argument is not constant: ~S." - (arg-name arg))) - (continuation-value from-end)) + (unless (constant-continuation-p cont) + (give-up-ir1-transform "Argument is not constant: ~S." + (arg-name arg))) + (continuation-value from-end)) default)) ;;; If Arg is a constant and is EQL to X, then return T, otherwise NIL. If @@ -443,8 +443,8 @@ (declare (type (or arg null) x)) (if (and arg (arg-cont arg)) (let ((cont (arg-cont arg))) - (and (constant-continuation-p cont) - (eql (continuation-value cont) x))) + (and (constant-continuation-p cont) + (eql (continuation-value cont) x))) (eql default x))) (defstruct (iterator (:copier nil)) @@ -482,65 +482,65 @@ ;;; the iteration is forward or backward, then GIVE-UP. (defun make-sequence-iterator (sequence type &key start end from-end index) (declare (symbol sequence) (type ctype type) - (type (or arg null) start end from-end) - (type (or symbol null) index)) + (type (or arg null) start end from-end) + (type (or symbol null) index)) (let ((from-end (arg-constant-value from-end nil))) (cond ((csubtypep type (specifier-type 'vector)) - (let* ((n-stop (gensym)) - (n-idx (or index (gensym))) - (start (default-arg 0 start)) - (end (default-arg `(length ,sequence) end))) - (make-iterator - :kind :normal - :binds `((,n-idx ,(if from-end `(1- ,end) ,start)) - (,n-stop ,(if from-end `(1- ,start) ,end))) - :decls `((type neg-index ,n-idx ,n-stop)) - :current `(aref ,sequence ,n-idx) - :done `(,(if from-end '<= '>=) ,n-idx ,n-stop) - :next `(setq ,n-idx - ,(if from-end `(1- ,n-idx) `(1+ ,n-idx))) - :length (if from-end - `(- ,n-idx ,n-stop) - `(- ,n-stop ,n-idx))))) - ((csubtypep type (specifier-type 'list)) - (let* ((n-stop (if (and end (not from-end)) (gensym) nil)) - (n-current (gensym)) - (start-p (not (arg-eql start 0 0))) - (end-p (not (arg-eql end nil nil))) - (start (default-arg start 0)) - (end (default-arg end nil))) - (make-iterator - :binds `((,n-current - ,(if from-end - (if (or start-p end-p) - `(nreverse (subseq ,sequence ,start - ,@(when end `(,end)))) - `(reverse ,sequence)) - (if start-p - `(nthcdr ,start ,sequence) - sequence))) - ,@(when n-stop - `((,n-stop (nthcdr (the index - (- ,end ,start)) - ,n-current)))) - ,@(when index - `((,index ,(if from-end `(1- ,end) start))))) - :kind :normal - :decls `((list ,n-current ,n-end) - ,@(when index `((type neg-index ,index)))) - :current `(car ,n-current) - :done `(eq ,n-current ,n-stop) - :length `(- ,(or end `(length ,sequence)) ,start) - :next `(progn - (setq ,n-current (cdr ,n-current)) - ,@(when index - `((setq ,n-idx - ,(if from-end - `(1- ,index) - `(1+ ,index))))))))) - (t - (give-up-ir1-transform - "can't tell whether sequence is a list or a vector"))))) + (let* ((n-stop (gensym)) + (n-idx (or index (gensym))) + (start (default-arg 0 start)) + (end (default-arg `(length ,sequence) end))) + (make-iterator + :kind :normal + :binds `((,n-idx ,(if from-end `(1- ,end) ,start)) + (,n-stop ,(if from-end `(1- ,start) ,end))) + :decls `((type neg-index ,n-idx ,n-stop)) + :current `(aref ,sequence ,n-idx) + :done `(,(if from-end '<= '>=) ,n-idx ,n-stop) + :next `(setq ,n-idx + ,(if from-end `(1- ,n-idx) `(1+ ,n-idx))) + :length (if from-end + `(- ,n-idx ,n-stop) + `(- ,n-stop ,n-idx))))) + ((csubtypep type (specifier-type 'list)) + (let* ((n-stop (if (and end (not from-end)) (gensym) nil)) + (n-current (gensym)) + (start-p (not (arg-eql start 0 0))) + (end-p (not (arg-eql end nil nil))) + (start (default-arg start 0)) + (end (default-arg end nil))) + (make-iterator + :binds `((,n-current + ,(if from-end + (if (or start-p end-p) + `(nreverse (subseq ,sequence ,start + ,@(when end `(,end)))) + `(reverse ,sequence)) + (if start-p + `(nthcdr ,start ,sequence) + sequence))) + ,@(when n-stop + `((,n-stop (nthcdr (the index + (- ,end ,start)) + ,n-current)))) + ,@(when index + `((,index ,(if from-end `(1- ,end) start))))) + :kind :normal + :decls `((list ,n-current ,n-end) + ,@(when index `((type neg-index ,index)))) + :current `(car ,n-current) + :done `(eq ,n-current ,n-stop) + :length `(- ,(or end `(length ,sequence)) ,start) + :next `(progn + (setq ,n-current (cdr ,n-current)) + ,@(when index + `((setq ,n-idx + ,(if from-end + `(1- ,index) + `(1+ ,index))))))))) + (t + (give-up-ir1-transform + "can't tell whether sequence is a list or a vector"))))) ;;; Make an iterator used for constructing result sequences. Name is a ;;; variable to be bound to the result sequence. Type is the type of result @@ -556,32 +556,32 @@ #!+sb-doc "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*" (collect ((binds) - (defs)) + (defs)) (dolist (spec specs) `(let ((body (progn ,@body)) - (n-fun (arg-name ,(second spec))) - (fun-cont (arg-cont ,(second spec)))) - (cond ((not fun-cont) - `(macrolet ((,',(first spec) (&rest args) - `(,',',(third spec) ,@args))) - ,body)) - ((not (csubtypep (continuation-type fun-cont) - (specifier-type 'function))) - (when (policy *compiler-error-context* - (> speed inhibit-warnings)) - (compiler-notify - "~S may not be a function, so must coerce at run-time." - n-fun)) - (once-only ((n-fun `(if (functionp ,n-fun) - ,n-fun - (symbol-function ,n-fun)))) - `(macrolet ((,',(first spec) (&rest args) - `(funcall ,',n-fun ,@args))) - ,body))) - (t - `(macrolet ((,',(first spec) (&rest args) - `(funcall ,',n-fun ,@args))) - ,body))))))) + (n-fun (arg-name ,(second spec))) + (fun-cont (arg-cont ,(second spec)))) + (cond ((not fun-cont) + `(macrolet ((,',(first spec) (&rest args) + `(,',',(third spec) ,@args))) + ,body)) + ((not (csubtypep (continuation-type fun-cont) + (specifier-type 'function))) + (when (policy *compiler-error-context* + (> speed inhibit-warnings)) + (compiler-notify + "~S may not be a function, so must coerce at run-time." + n-fun)) + (once-only ((n-fun `(if (functionp ,n-fun) + ,n-fun + (symbol-function ,n-fun)))) + `(macrolet ((,',(first spec) (&rest args) + `(funcall ,',n-fun ,@args))) + ,body))) + (t + `(macrolet ((,',(first spec) (&rest args) + `(funcall ,',n-fun ,@args))) + ,body))))))) ;;; Wrap code around the result of the body to define Name as a local macro ;;; that returns true when its arguments satisfy the test according to the Args @@ -591,8 +591,8 @@ `(let ((not-p (arg-cont ,test-not))) (when (and (arg-cont ,test) not-p) (abort-ir1-transform "Both ~S and ~S were supplied." - (arg-name ,test) - (arg-name ,test-not))) + (arg-name ,test) + (arg-name ,test-not))) (coerce-funs ((,name (if not-p ,test-not ,test) eql)) ,@body))) |# @@ -643,7 +643,7 @@ (- start2 start1)))))) index) - (t nil)) + (t nil)) ,(if ',equalp 'end1 nil)))))) (def string<* t nil) (def string<=* t t) @@ -782,22 +782,22 @@ ;;; * :TEST 'EQL or :TEST #'EQL ;;; * :FROM-END NIL (or :FROM-END non-NIL, with a little ingenuity) (deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2) - (simple-string simple-string &rest t) - * - :policy (> speed (max space safety))) + (simple-string simple-string &rest t) + * + :policy (> speed (max space safety))) `(block search (let ((end1 (or end1 (length pattern))) - (end2 (or end2 (length text)))) + (end2 (or end2 (length text)))) (do ((index2 start2 (1+ index2))) - ((>= index2 end2) nil) - (when (do ((index1 start1 (1+ index1)) - (index2 index2 (1+ index2))) - ((>= index1 end1) t) - (when (= index2 end2) - (return-from search nil)) - (when (char/= (char pattern index1) (char text index2)) - (return nil))) - (return index2)))))) + ((>= index2 end2) nil) + (when (do ((index1 start1 (1+ index1)) + (index2 index2 (1+ index2))) + ((>= index1 end1) t) + (when (= index2 end2) + (return-from search nil)) + (when (char/= (char pattern index1) (char text index2)) + (return nil))) + (return index2)))))) ;;; FIXME: It seems as though it should be possible to make a DEFUN ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to @@ -809,10 +809,10 @@ ;;; FIXME: disabled for sb-unicode: probably want it back #!-sb-unicode (deftransform concatenate ((rtype &rest sequences) - (t &rest (or simple-base-string - (simple-array nil (*)))) - simple-base-string - :policy (< safety 3)) + (t &rest (or simple-base-string + (simple-array nil (*)))) + simple-base-string + :policy (< safety 3)) (loop for rest-seqs on sequences for n-seq = (gensym "N-SEQ") for n-length = (gensym "N-LENGTH") @@ -823,8 +823,8 @@ collect n-length into all-lengths collect next-start into starts collect `(if (and (typep ,n-seq '(simple-array nil (*))) - (> ,n-length 0)) - (error 'nil-array-accessed-error) + (> ,n-length 0)) + (error 'nil-array-accessed-error) (#.(let* ((i (position 'character sb!kernel::*specialized-array-element-types*)) (saetp (aref sb!vm:*specialized-array-element-type-properties* i)) (n-bits (sb!vm:saetp-n-bits saetp))) @@ -850,19 +850,19 @@ (defoptimizer (car derive-type) ((cons)) (let ((type (lvar-type cons)) - (null-type (specifier-type 'null))) + (null-type (specifier-type 'null))) (cond ((eq type null-type) - null-type) - ((cons-type-p type) - (cons-type-car-type type))))) + null-type) + ((cons-type-p type) + (cons-type-car-type type))))) (defoptimizer (cdr derive-type) ((cons)) (let ((type (lvar-type cons)) - (null-type (specifier-type 'null))) + (null-type (specifier-type 'null))) (cond ((eq type null-type) - null-type) - ((cons-type-p type) - (cons-type-cdr-type type))))) + null-type) + ((cons-type-p type) + (cons-type-cdr-type type))))) ;;;; FIND, POSITION, and their -IF and -IF-NOT variants @@ -872,61 +872,61 @@ (defun check-inlineability-of-find-position-if (sequence from-end) (let ((ctype (lvar-type sequence))) (cond ((csubtypep ctype (specifier-type 'vector)) - ;; It's not worth trying to inline vector code unless we - ;; know a fair amount about it at compile time. - (upgraded-element-type-specifier-or-give-up sequence) - (unless (constant-lvar-p from-end) - (give-up-ir1-transform - "FROM-END argument value not known at compile time"))) - ((csubtypep ctype (specifier-type 'list)) - ;; Inlining on lists is generally worthwhile. - ) - (t - (give-up-ir1-transform - "sequence type not known at compile time"))))) + ;; It's not worth trying to inline vector code unless we + ;; know a fair amount about it at compile time. + (upgraded-element-type-specifier-or-give-up sequence) + (unless (constant-lvar-p from-end) + (give-up-ir1-transform + "FROM-END argument value not known at compile time"))) + ((csubtypep ctype (specifier-type 'list)) + ;; Inlining on lists is generally worthwhile. + ) + (t + (give-up-ir1-transform + "sequence type not known at compile time"))))) ;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data (macrolet ((def (name condition) - `(deftransform ,name ((predicate sequence from-end start end key) - (function list t t t function) - * - :policy (> speed space)) - "expand inline" - `(let ((index 0) - (find nil) - (position nil)) - (declare (type index index)) - (dolist (i sequence - (if (and end (> end index)) - (sb!impl::signal-bounding-indices-bad-error - sequence start end) - (values find position))) - (let ((key-i (funcall key i))) - (when (and end (>= index end)) - (return (values find position))) - (when (>= index start) - (,',condition (funcall predicate key-i) - ;; This hack of dealing with non-NIL - ;; FROM-END for list data by iterating - ;; forward through the list and keeping - ;; track of the last time we found a match - ;; might be more screwy than what the user - ;; expects, but it seems to be allowed by - ;; the ANSI standard. (And if the user is - ;; screwy enough to ask for FROM-END - ;; behavior on list data, turnabout is - ;; fair play.) - ;; - ;; It's also not enormously efficient, - ;; calling PREDICATE and KEY more often - ;; than necessary; but all the - ;; alternatives seem to have their own - ;; efficiency problems. - (if from-end - (setf find i - position index) - (return (values i index)))))) - (incf index)))))) + `(deftransform ,name ((predicate sequence from-end start end key) + (function list t t t function) + * + :policy (> speed space)) + "expand inline" + `(let ((index 0) + (find nil) + (position nil)) + (declare (type index index)) + (dolist (i sequence + (if (and end (> end index)) + (sb!impl::signal-bounding-indices-bad-error + sequence start end) + (values find position))) + (let ((key-i (funcall key i))) + (when (and end (>= index end)) + (return (values find position))) + (when (>= index start) + (,',condition (funcall predicate key-i) + ;; This hack of dealing with non-NIL + ;; FROM-END for list data by iterating + ;; forward through the list and keeping + ;; track of the last time we found a match + ;; might be more screwy than what the user + ;; expects, but it seems to be allowed by + ;; the ANSI standard. (And if the user is + ;; screwy enough to ask for FROM-END + ;; behavior on list data, turnabout is + ;; fair play.) + ;; + ;; It's also not enormously efficient, + ;; calling PREDICATE and KEY more often + ;; than necessary; but all the + ;; alternatives seem to have their own + ;; efficiency problems. + (if from-end + (setf find i + position index) + (return (values i index)))))) + (incf index)))))) (def %find-position-if when) (def %find-position-if-not unless)) @@ -934,62 +934,62 @@ ;;; without loss of efficiency. (I.e., the optimizer should be able ;;; to straighten everything out.) (deftransform %find-position ((item sequence from-end start end key test) - (t list t t t t t) - * - :policy (> speed space)) + (t list t t t t t) + * + :policy (> speed space)) "expand inline" '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test))) - ;; The order of arguments for asymmetric tests - ;; (e.g. #'<, as opposed to order-independent - ;; tests like #'=) is specified in the spec - ;; section 17.2.1 -- the O/Zi stuff there. - (lambda (i) - (funcall test-fun item i))) - sequence - from-end - start - end - (%coerce-callable-to-fun key))) + ;; The order of arguments for asymmetric tests + ;; (e.g. #'<, as opposed to order-independent + ;; tests like #'=) is specified in the spec + ;; section 17.2.1 -- the O/Zi stuff there. + (lambda (i) + (funcall test-fun item i))) + sequence + from-end + start + end + (%coerce-callable-to-fun key))) ;;; The inline expansions for the VECTOR case are saved as macros so ;;; that we can share them between the DEFTRANSFORMs and the default ;;; cases in the DEFUNs. (This isn't needed for the LIST case, because ;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.) (defun %find-position-or-find-position-if-vector-expansion (sequence-arg - from-end - start - end-arg - element - done-p-expr) + from-end + start + end-arg + element + done-p-expr) (with-unique-names (offset block index n-sequence sequence n-end end) `(let ((,n-sequence ,sequence-arg) - (,n-end ,end-arg)) + (,n-end ,end-arg)) (with-array-data ((,sequence ,n-sequence :offset-var ,offset) - (,start ,start) - (,end (%check-vector-sequence-bounds - ,n-sequence ,start ,n-end))) + (,start ,start) + (,end (%check-vector-sequence-bounds + ,n-sequence ,start ,n-end))) (block ,block - (macrolet ((maybe-return () - '(let ((,element (aref ,sequence ,index))) - (when ,done-p-expr - (return-from ,block - (values ,element - (- ,index ,offset))))))) - (if ,from-end - (loop for ,index - ;; (If we aren't fastidious about declaring that - ;; INDEX might be -1, then (FIND 1 #() :FROM-END T) - ;; can send us off into never-never land, since - ;; INDEX is initialized to -1.) - of-type index-or-minus-1 - from (1- ,end) downto ,start do - (maybe-return)) - (loop for ,index of-type index from ,start below ,end do - (maybe-return)))) - (values nil nil)))))) + (macrolet ((maybe-return () + '(let ((,element (aref ,sequence ,index))) + (when ,done-p-expr + (return-from ,block + (values ,element + (- ,index ,offset))))))) + (if ,from-end + (loop for ,index + ;; (If we aren't fastidious about declaring that + ;; INDEX might be -1, then (FIND 1 #() :FROM-END T) + ;; can send us off into never-never land, since + ;; INDEX is initialized to -1.) + of-type index-or-minus-1 + from (1- ,end) downto ,start do + (maybe-return)) + (loop for ,index of-type index from ,start below ,end do + (maybe-return)))) + (values nil nil)))))) (def!macro %find-position-vector-macro (item sequence - from-end start end key test) + from-end start end key test) (with-unique-names (element) (%find-position-or-find-position-if-vector-expansion sequence @@ -1003,7 +1003,7 @@ `(funcall ,test ,item (funcall ,key ,element))))) (def!macro %find-position-if-vector-macro (predicate sequence - from-end start end key) + from-end start end key) (with-unique-names (element) (%find-position-or-find-position-if-vector-expansion sequence @@ -1014,7 +1014,7 @@ `(funcall ,predicate (funcall ,key ,element))))) (def!macro %find-position-if-not-vector-macro (predicate sequence - from-end start end key) + from-end start end key) (with-unique-names (element) (%find-position-or-find-position-if-vector-expansion sequence @@ -1027,37 +1027,37 @@ ;;; %FIND-POSITION, %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for ;;; VECTOR data (deftransform %find-position-if ((predicate sequence from-end start end key) - (function vector t t t function) - * - :policy (> speed space)) + (function vector t t t function) + * + :policy (> speed space)) "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-if-vector-macro predicate sequence - from-end start end key)) + from-end start end key)) (deftransform %find-position-if-not ((predicate sequence from-end start end key) - (function vector t t t function) - * - :policy (> speed space)) + (function vector t t t function) + * + :policy (> speed space)) "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-if-not-vector-macro predicate sequence from-end start end key)) (deftransform %find-position ((item sequence from-end start end key test) - (t vector t t t function function) - * - :policy (> speed space)) + (t vector t t t function function) + * + :policy (> speed space)) "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-vector-macro item sequence - from-end start end key test)) + from-end start end key test)) ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, ;;; POSITION-IF, etc. (define-source-transform effective-find-position-test (test test-not) (once-only ((test test) - (test-not test-not)) + (test-not test-not)) `(cond ((and ,test ,test-not) (error "can't specify both :TEST and :TEST-NOT")) @@ -1071,33 +1071,33 @@ (define-source-transform effective-find-position-key (key) (once-only ((key key)) `(if ,key - (%coerce-callable-to-fun ,key) - #'identity))) + (%coerce-callable-to-fun ,key) + #'identity))) (macrolet ((define-find-position (fun-name values-index) - `(deftransform ,fun-name ((item sequence &key - from-end (start 0) end - key test test-not)) - '(nth-value ,values-index - (%find-position item sequence - from-end start - end - (effective-find-position-key key) - (effective-find-position-test - test test-not)))))) + `(deftransform ,fun-name ((item sequence &key + from-end (start 0) end + key test test-not)) + '(nth-value ,values-index + (%find-position item sequence + from-end start + end + (effective-find-position-key key) + (effective-find-position-test + test test-not)))))) (define-find-position find 0) (define-find-position position 1)) (macrolet ((define-find-position-if (fun-name values-index) - `(deftransform ,fun-name ((predicate sequence &key - from-end (start 0) - end key)) - '(nth-value - ,values-index - (%find-position-if (%coerce-callable-to-fun predicate) - sequence from-end - start end - (effective-find-position-key key)))))) + `(deftransform ,fun-name ((predicate sequence &key + from-end (start 0) + end key)) + '(nth-value + ,values-index + (%find-position-if (%coerce-callable-to-fun predicate) + sequence from-end + start end + (effective-find-position-key key)))))) (define-find-position-if find-if 0) (define-find-position-if position-if 1)) @@ -1122,14 +1122,14 @@ ;;; FIXME: Maybe remove uses of these deprecated functions within the ;;; implementation of SBCL. (macrolet ((define-find-position-if-not (fun-name values-index) - `(deftransform ,fun-name ((predicate sequence &key - from-end (start 0) - end key)) - '(nth-value - ,values-index - (%find-position-if-not (%coerce-callable-to-fun predicate) - sequence from-end - start end - (effective-find-position-key key)))))) + `(deftransform ,fun-name ((predicate sequence &key + from-end (start 0) + end key)) + '(nth-value + ,values-index + (%find-position-if-not (%coerce-callable-to-fun predicate) + sequence from-end + start end + (effective-find-position-key key)))))) (define-find-position-if-not find-if-not 0) (define-find-position-if-not position-if-not 1)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index b4214fc..04060f8 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -34,8 +34,8 @@ (with-unique-names (rest n-value) `(let ((,n-value ,value)) (lambda (&rest ,rest) - (declare (ignore ,rest)) - ,n-value)))) + (declare (ignore ,rest)) + ,n-value)))) ;;; If the function has a known number of arguments, then return a ;;; lambda with the appropriate fixed number of args. If the @@ -48,13 +48,13 @@ (cond ((and min (eql min max)) (let ((dums (make-gensym-list min))) - `#'(lambda ,dums (not (funcall fun ,@dums))))) + `#'(lambda ,dums (not (funcall fun ,@dums))))) ((awhen (node-lvar node) (let ((dest (lvar-dest it))) (and (combination-p dest) (eq (combination-fun dest) it)))) '#'(lambda (&rest args) - (not (apply fun args)))) + (not (apply fun args)))) (t (give-up-ir1-transform "The function doesn't have a fixed argument count."))))) @@ -66,17 +66,17 @@ (if (/= (length form) 2) (values nil t) (let* ((name (car form)) - (string (symbol-name - (etypecase name - (symbol name) - (leaf (leaf-source-name name)))))) - (do ((i (- (length string) 2) (1- i)) - (res (cadr form) - `(,(ecase (char string i) - (#\A 'car) - (#\D 'cdr)) - ,res))) - ((zerop i) res))))) + (string (symbol-name + (etypecase name + (symbol name) + (leaf (leaf-source-name name)))))) + (do ((i (- (length string) 2) (1- i)) + (res (cadr form) + `(,(ecase (char string i) + (#\A 'car) + (#\D 'cdr)) + ,res))) + ((zerop i) res))))) ;;; Make source transforms to turn CxR forms into combinations of CAR ;;; and CDR. ANSI specifies that everything up to 4 A/D operations is @@ -86,16 +86,16 @@ ;; Iterate over BUF = all names CxR where x = an I-element ;; string of #\A or #\D characters. (let ((buf (make-string (+ 2 i)))) - (setf (aref buf 0) #\C - (aref buf (1+ i)) #\R) - (dotimes (j (ash 2 i)) - (declare (type index j)) - (dotimes (k i) - (declare (type index k)) - (setf (aref buf (1+ k)) - (if (logbitp k j) #\A #\D))) - (setf (info :function :source-transform (intern buf)) - #'source-transform-cxr)))) + (setf (aref buf 0) #\C + (aref buf (1+ i)) #\R) + (dotimes (j (ash 2 i)) + (declare (type index j)) + (dotimes (k i) + (declare (type index k)) + (setf (aref buf (1+ k)) + (if (logbitp k j) #\A #\D))) + (setf (info :function :source-transform (intern buf)) + #'source-transform-cxr)))) (/show0 "done setting CxR source transforms") ;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming @@ -137,15 +137,15 @@ (give-up-ir1-transform)) (let ((n (lvar-value n))) (when (> n - (if (policy node (and (= speed 3) (= space 0))) - *extreme-nthcdr-open-code-limit* - *default-nthcdr-open-code-limit*)) + (if (policy node (and (= speed 3) (= space 0))) + *extreme-nthcdr-open-code-limit* + *default-nthcdr-open-code-limit*)) (give-up-ir1-transform)) (labels ((frob (n) - (if (zerop n) - 'l - `(cdr ,(frob (1- n)))))) + (if (zerop n) + 'l + `(cdr ,(frob (1- n)))))) (frob n)))) ;;;; arithmetic and numerology @@ -164,11 +164,11 @@ ;;; inline expansion. (macrolet ((deffrob (fun) - `(define-source-transform ,fun (x &optional (y nil y-p)) - (declare (ignore y)) - (if y-p - (values nil t) - `(,',fun ,x 1))))) + `(define-source-transform ,fun (x &optional (y nil y-p)) + (declare (ignore y)) + (if y-p + (values nil t) + `(,',fun ,x 1))))) (deffrob truncate) (deffrob round) #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) @@ -180,7 +180,7 @@ (deftransform logbitp ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits) - (unsigned-byte #.sb!vm:n-word-bits)))) + (unsigned-byte #.sb!vm:n-word-bits)))) `(if (>= index #.sb!vm:n-word-bits) (minusp integer) (not (zerop (logand integer (ash 1 index)))))) @@ -197,13 +197,13 @@ (define-source-transform numerator (num) (once-only ((n-num `(the rational ,num))) `(if (ratiop ,n-num) - (%numerator ,n-num) - ,n-num))) + (%numerator ,n-num) + ,n-num))) (define-source-transform denominator (num) (once-only ((n-num `(the rational ,num))) `(if (ratiop ,n-num) - (%denominator ,n-num) - 1))) + (%denominator ,n-num) + 1))) ;;;; interval arithmetic for computing bounds ;;;; @@ -227,11 +227,11 @@ ;;; operators, but imposing a total order on the floating points such ;;; that negative zeros are strictly less than positive zeros. (macrolet ((def (name op) - `(defun ,name (x y) - (declare (real x y)) - (if (and (floatp x) (floatp y) (zerop x) (zerop y)) - (,op (float-sign x) (float-sign y)) - (,op x y))))) + `(defun ,name (x y) + (declare (real x y)) + (if (and (floatp x) (floatp y) (zerop x) (zerop y)) + (,op (float-sign x) (float-sign y)) + (,op x y))))) (def signed-zero->= >=) (def signed-zero-> >) (def signed-zero-= =) @@ -242,33 +242,33 @@ ;;; A bound is open if it is a list containing a number, just like ;;; Lisp says. NIL means unbounded. (defstruct (interval (:constructor %make-interval) - (:copier nil)) + (:copier nil)) low high) (defun make-interval (&key low high) (labels ((normalize-bound (val) - (cond #-sb-xc-host + (cond #-sb-xc-host ((and (floatp val) - (float-infinity-p val)) - ;; Handle infinities. - nil) - ((or (numberp val) - (eq val nil)) - ;; Handle any closed bounds. - val) - ((listp val) - ;; We have an open bound. Normalize the numeric - ;; bound. If the normalized bound is still a number - ;; (not nil), keep the bound open. Otherwise, the - ;; bound is really unbounded, so drop the openness. - (let ((new-val (normalize-bound (first val)))) - (when new-val - ;; The bound exists, so keep it open still. - (list new-val)))) - (t - (error "unknown bound type in MAKE-INTERVAL"))))) + (float-infinity-p val)) + ;; Handle infinities. + nil) + ((or (numberp val) + (eq val nil)) + ;; Handle any closed bounds. + val) + ((listp val) + ;; We have an open bound. Normalize the numeric + ;; bound. If the normalized bound is still a number + ;; (not nil), keep the bound open. Otherwise, the + ;; bound is really unbounded, so drop the openness. + (let ((new-val (normalize-bound (first val)))) + (when new-val + ;; The bound exists, so keep it open still. + (list new-val)))) + (t + (error "unknown bound type in MAKE-INTERVAL"))))) (%make-interval :low (normalize-bound low) - :high (normalize-bound high)))) + :high (normalize-bound high)))) ;;; Given a number X, create a form suitable as a bound for an ;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL. @@ -282,14 +282,14 @@ (declare (type function f)) (and x (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - ;; With these traps masked, we might get things like infinity - ;; or negative infinity returned. Check for this and return - ;; NIL to indicate unbounded. - (let ((y (funcall f (type-bound-number x)))) - (if (and (floatp y) - (float-infinity-p y)) - nil - (set-bound (funcall f (type-bound-number x)) (consp x))))))) + ;; With these traps masked, we might get things like infinity + ;; or negative infinity returned. Check for this and return + ;; NIL to indicate unbounded. + (let ((y (funcall f (type-bound-number x)))) + (if (and (floatp y) + (float-infinity-p y)) + nil + (set-bound (funcall f (type-bound-number x)) (consp x))))))) ;;; Apply a binary operator OP to two bounds X and Y. The result is ;;; NIL if either is NIL. Otherwise bound is computed and the result @@ -299,15 +299,15 @@ (defmacro bound-binop (op x y) `(and ,x ,y (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - (set-bound (,op (type-bound-number ,x) - (type-bound-number ,y)) - (or (consp ,x) (consp ,y)))))) + (set-bound (,op (type-bound-number ,x) + (type-bound-number ,y)) + (or (consp ,x) (consp ,y)))))) ;;; Convert a numeric-type object to an interval object. (defun numeric-type->interval (x) (declare (type numeric-type x)) (make-interval :low (numeric-type-low x) - :high (numeric-type-high x))) + :high (numeric-type-high x))) (defun type-approximate-interval (type) (declare (type ctype type)) @@ -334,7 +334,7 @@ (defun copy-interval (x) (declare (type interval x)) (make-interval :low (copy-interval-limit (interval-low x)) - :high (copy-interval-limit (interval-high x)))) + :high (copy-interval-limit (interval-high x)))) ;;; Given a point P contained in the interval X, split X into two ;;; interval at the point P. If CLOSE-LOWER is T, then the left @@ -342,31 +342,31 @@ ;;; contains P. You can specify both to be T or NIL. (defun interval-split (p x &optional close-lower close-upper) (declare (type number p) - (type interval x)) + (type interval x)) (list (make-interval :low (copy-interval-limit (interval-low x)) - :high (if close-lower p (list p))) - (make-interval :low (if close-upper (list p) p) - :high (copy-interval-limit (interval-high x))))) + :high (if close-lower p (list p))) + (make-interval :low (if close-upper (list p) p) + :high (copy-interval-limit (interval-high x))))) ;;; Return the closure of the interval. That is, convert open bounds ;;; to closed bounds. (defun interval-closure (x) (declare (type interval x)) (make-interval :low (type-bound-number (interval-low x)) - :high (type-bound-number (interval-high x)))) + :high (type-bound-number (interval-high x)))) ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return ;;; '-. Otherwise return NIL. (defun interval-range-info (x &optional (point 0)) (declare (type interval x)) (let ((lo (interval-low x)) - (hi (interval-high x))) + (hi (interval-high x))) (cond ((and lo (signed-zero->= (type-bound-number lo) point)) - '+) - ((and hi (signed-zero->= point (type-bound-number hi))) - '-) - (t - nil)))) + '+) + ((and hi (signed-zero->= point (type-bound-number hi))) + '-) + (t + nil)))) ;;; Test to see whether the interval X is bounded. HOW determines the ;;; test, and should be either ABOVE, BELOW, or BOTH. @@ -384,36 +384,36 @@ ;;; account that the interval might not be closed. (defun interval-contains-p (p x) (declare (type number p) - (type interval x)) + (type interval x)) ;; Does the interval X contain the number P? This would be a lot ;; easier if all intervals were closed! (let ((lo (interval-low x)) - (hi (interval-high x))) + (hi (interval-high x))) (cond ((and lo hi) - ;; The interval is bounded - (if (and (signed-zero-<= (type-bound-number lo) p) - (signed-zero-<= p (type-bound-number hi))) - ;; P is definitely in the closure of the interval. - ;; We just need to check the end points now. - (cond ((signed-zero-= p (type-bound-number lo)) - (numberp lo)) - ((signed-zero-= p (type-bound-number hi)) - (numberp hi)) - (t t)) - nil)) - (hi - ;; Interval with upper bound - (if (signed-zero-< p (type-bound-number hi)) - t - (and (numberp hi) (signed-zero-= p hi)))) - (lo - ;; Interval with lower bound - (if (signed-zero-> p (type-bound-number lo)) - t - (and (numberp lo) (signed-zero-= p lo)))) - (t - ;; Interval with no bounds - t)))) + ;; The interval is bounded + (if (and (signed-zero-<= (type-bound-number lo) p) + (signed-zero-<= p (type-bound-number hi))) + ;; P is definitely in the closure of the interval. + ;; We just need to check the end points now. + (cond ((signed-zero-= p (type-bound-number lo)) + (numberp lo)) + ((signed-zero-= p (type-bound-number hi)) + (numberp hi)) + (t t)) + nil)) + (hi + ;; Interval with upper bound + (if (signed-zero-< p (type-bound-number hi)) + t + (and (numberp hi) (signed-zero-= p hi)))) + (lo + ;; Interval with lower bound + (if (signed-zero-> p (type-bound-number lo)) + t + (and (numberp lo) (signed-zero-= p lo)))) + (t + ;; Interval with no bounds + t)))) ;;; Determine whether two intervals X and Y intersect. Return T if so. ;;; If CLOSED-INTERVALS-P is T, the treat the intervals as if they @@ -427,11 +427,11 @@ (declare (type interval x y)) (multiple-value-bind (intersect diff) (interval-intersection/difference (if closed-intervals-p - (interval-closure x) - x) - (if closed-intervals-p - (interval-closure y) - y)) + (interval-closure x) + x) + (if closed-intervals-p + (interval-closure y) + y)) (declare (ignore diff)) intersect)) @@ -443,15 +443,15 @@ (defun interval-adjacent-p (x y) (declare (type interval x y)) (flet ((adjacent (lo hi) - ;; Check to see whether lo and hi are adjacent. If either is - ;; nil, they can't be adjacent. - (when (and lo hi (= (type-bound-number lo) (type-bound-number hi))) - ;; The bounds are equal. They are adjacent if one of - ;; them is closed (a number). If both are open (consp), - ;; then there is a number that lies between them. - (or (numberp lo) (numberp hi))))) + ;; Check to see whether lo and hi are adjacent. If either is + ;; nil, they can't be adjacent. + (when (and lo hi (= (type-bound-number lo) (type-bound-number hi))) + ;; The bounds are equal. They are adjacent if one of + ;; them is closed (a number). If both are open (consp), + ;; then there is a number that lies between them. + (or (numberp lo) (numberp hi))))) (or (adjacent (interval-low y) (interval-high x)) - (adjacent (interval-low x) (interval-high y))))) + (adjacent (interval-low x) (interval-high y))))) ;;; Compute the intersection and difference between two intervals. ;;; Two values are returned: the intersection and the difference. @@ -467,60 +467,60 @@ (defun interval-intersection/difference (x y) (declare (type interval x y)) (let ((x-lo (interval-low x)) - (x-hi (interval-high x)) - (y-lo (interval-low y)) - (y-hi (interval-high y))) + (x-hi (interval-high x)) + (y-lo (interval-low y)) + (y-hi (interval-high y))) (labels - ((opposite-bound (p) - ;; If p is an open bound, make it closed. If p is a closed - ;; bound, make it open. - (if (listp p) - (first p) - (list p))) - (test-number (p int) - ;; Test whether P is in the interval. - (when (interval-contains-p (type-bound-number p) - (interval-closure int)) - (let ((lo (interval-low int)) - (hi (interval-high int))) - ;; Check for endpoints. - (cond ((and lo (= (type-bound-number p) (type-bound-number lo))) - (not (and (consp p) (numberp lo)))) - ((and hi (= (type-bound-number p) (type-bound-number hi))) - (not (and (numberp p) (consp hi)))) - (t t))))) - (test-lower-bound (p int) - ;; P is a lower bound of an interval. - (if p - (test-number p int) - (not (interval-bounded-p int 'below)))) - (test-upper-bound (p int) - ;; P is an upper bound of an interval. - (if p - (test-number p int) - (not (interval-bounded-p int 'above))))) + ((opposite-bound (p) + ;; If p is an open bound, make it closed. If p is a closed + ;; bound, make it open. + (if (listp p) + (first p) + (list p))) + (test-number (p int) + ;; Test whether P is in the interval. + (when (interval-contains-p (type-bound-number p) + (interval-closure int)) + (let ((lo (interval-low int)) + (hi (interval-high int))) + ;; Check for endpoints. + (cond ((and lo (= (type-bound-number p) (type-bound-number lo))) + (not (and (consp p) (numberp lo)))) + ((and hi (= (type-bound-number p) (type-bound-number hi))) + (not (and (numberp p) (consp hi)))) + (t t))))) + (test-lower-bound (p int) + ;; P is a lower bound of an interval. + (if p + (test-number p int) + (not (interval-bounded-p int 'below)))) + (test-upper-bound (p int) + ;; P is an upper bound of an interval. + (if p + (test-number p int) + (not (interval-bounded-p int 'above))))) (let ((x-lo-in-y (test-lower-bound x-lo y)) - (x-hi-in-y (test-upper-bound x-hi y)) - (y-lo-in-x (test-lower-bound y-lo x)) - (y-hi-in-x (test-upper-bound y-hi x))) - (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x) - ;; Intervals intersect. Let's compute the intersection - ;; and the difference. - (multiple-value-bind (lo left-lo left-hi) - (cond (x-lo-in-y (values x-lo y-lo (opposite-bound x-lo))) - (y-lo-in-x (values y-lo x-lo (opposite-bound y-lo)))) - (multiple-value-bind (hi right-lo right-hi) - (cond (x-hi-in-y - (values x-hi (opposite-bound x-hi) y-hi)) - (y-hi-in-x - (values y-hi (opposite-bound y-hi) x-hi))) - (values (make-interval :low lo :high hi) - (list (make-interval :low left-lo - :high left-hi) - (make-interval :low right-lo - :high right-hi)))))) - (t - (values nil (list x y)))))))) + (x-hi-in-y (test-upper-bound x-hi y)) + (y-lo-in-x (test-lower-bound y-lo x)) + (y-hi-in-x (test-upper-bound y-hi x))) + (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x) + ;; Intervals intersect. Let's compute the intersection + ;; and the difference. + (multiple-value-bind (lo left-lo left-hi) + (cond (x-lo-in-y (values x-lo y-lo (opposite-bound x-lo))) + (y-lo-in-x (values y-lo x-lo (opposite-bound y-lo)))) + (multiple-value-bind (hi right-lo right-hi) + (cond (x-hi-in-y + (values x-hi (opposite-bound x-hi) y-hi)) + (y-hi-in-x + (values y-hi (opposite-bound y-hi) x-hi))) + (values (make-interval :low lo :high hi) + (list (make-interval :low left-lo + :high left-hi) + (make-interval :low right-lo + :high right-hi)))))) + (t + (values nil (list x y)))))))) ;;; If intervals X and Y intersect, return a new interval that is the ;;; union of the two. If they do not intersect, return NIL. @@ -529,33 +529,33 @@ ;; If x and y intersect or are adjacent, create the union. ;; Otherwise return nil (when (or (interval-intersect-p x y) - (interval-adjacent-p x y)) + (interval-adjacent-p x y)) (flet ((select-bound (x1 x2 min-op max-op) - (let ((x1-val (type-bound-number x1)) - (x2-val (type-bound-number x2))) - (cond ((and x1 x2) - ;; Both bounds are finite. Select the right one. - (cond ((funcall min-op x1-val x2-val) - ;; x1 is definitely better. - x1) - ((funcall max-op x1-val x2-val) - ;; x2 is definitely better. - x2) - (t - ;; Bounds are equal. Select either - ;; value and make it open only if - ;; both were open. - (set-bound x1-val (and (consp x1) (consp x2)))))) - (t - ;; At least one bound is not finite. The - ;; non-finite bound always wins. - nil))))) + (let ((x1-val (type-bound-number x1)) + (x2-val (type-bound-number x2))) + (cond ((and x1 x2) + ;; Both bounds are finite. Select the right one. + (cond ((funcall min-op x1-val x2-val) + ;; x1 is definitely better. + x1) + ((funcall max-op x1-val x2-val) + ;; x2 is definitely better. + x2) + (t + ;; Bounds are equal. Select either + ;; value and make it open only if + ;; both were open. + (set-bound x1-val (and (consp x1) (consp x2)))))) + (t + ;; At least one bound is not finite. The + ;; non-finite bound always wins. + nil))))) (let* ((x-lo (copy-interval-limit (interval-low x))) - (x-hi (copy-interval-limit (interval-high x))) - (y-lo (copy-interval-limit (interval-low y))) - (y-hi (copy-interval-limit (interval-high y)))) - (make-interval :low (select-bound x-lo y-lo #'< #'>) - :high (select-bound x-hi y-hi #'> #'<)))))) + (x-hi (copy-interval-limit (interval-high x))) + (y-lo (copy-interval-limit (interval-low y))) + (y-hi (copy-interval-limit (interval-high y)))) + (make-interval :low (select-bound x-lo y-lo #'< #'>) + :high (select-bound x-hi y-hi #'> #'<)))))) ;;; return the minimal interval, containing X and Y (defun interval-approximate-union (x y) @@ -575,114 +575,114 @@ (defun interval-neg (x) (declare (type interval x)) (make-interval :low (bound-func #'- (interval-high x)) - :high (bound-func #'- (interval-low x)))) + :high (bound-func #'- (interval-low x)))) ;;; Add two intervals. (defun interval-add (x y) (declare (type interval x y)) (make-interval :low (bound-binop + (interval-low x) (interval-low y)) - :high (bound-binop + (interval-high x) (interval-high y)))) + :high (bound-binop + (interval-high x) (interval-high y)))) ;;; Subtract two intervals. (defun interval-sub (x y) (declare (type interval x y)) (make-interval :low (bound-binop - (interval-low x) (interval-high y)) - :high (bound-binop - (interval-high x) (interval-low y)))) + :high (bound-binop - (interval-high x) (interval-low y)))) ;;; Multiply two intervals. (defun interval-mul (x y) (declare (type interval x y)) (flet ((bound-mul (x y) - (cond ((or (null x) (null y)) - ;; Multiply by infinity is infinity - nil) - ((or (and (numberp x) (zerop x)) - (and (numberp y) (zerop y))) - ;; Multiply by closed zero is special. The result - ;; is always a closed bound. But don't replace this - ;; with zero; we want the multiplication to produce - ;; the correct signed zero, if needed. - (* (type-bound-number x) (type-bound-number y))) - ((or (and (floatp x) (float-infinity-p x)) - (and (floatp y) (float-infinity-p y))) - ;; Infinity times anything is infinity - nil) - (t - ;; General multiply. The result is open if either is open. - (bound-binop * x y))))) + (cond ((or (null x) (null y)) + ;; Multiply by infinity is infinity + nil) + ((or (and (numberp x) (zerop x)) + (and (numberp y) (zerop y))) + ;; Multiply by closed zero is special. The result + ;; is always a closed bound. But don't replace this + ;; with zero; we want the multiplication to produce + ;; the correct signed zero, if needed. + (* (type-bound-number x) (type-bound-number y))) + ((or (and (floatp x) (float-infinity-p x)) + (and (floatp y) (float-infinity-p y))) + ;; Infinity times anything is infinity + nil) + (t + ;; General multiply. The result is open if either is open. + (bound-binop * x y))))) (let ((x-range (interval-range-info x)) - (y-range (interval-range-info y))) + (y-range (interval-range-info y))) (cond ((null x-range) - ;; Split x into two and multiply each separately - (destructuring-bind (x- x+) (interval-split 0 x t t) - (interval-merge-pair (interval-mul x- y) - (interval-mul x+ y)))) - ((null y-range) - ;; Split y into two and multiply each separately - (destructuring-bind (y- y+) (interval-split 0 y t t) - (interval-merge-pair (interval-mul x y-) - (interval-mul x y+)))) - ((eq x-range '-) - (interval-neg (interval-mul (interval-neg x) y))) - ((eq y-range '-) - (interval-neg (interval-mul x (interval-neg y)))) - ((and (eq x-range '+) (eq y-range '+)) - ;; If we are here, X and Y are both positive. - (make-interval - :low (bound-mul (interval-low x) (interval-low y)) - :high (bound-mul (interval-high x) (interval-high y)))) - (t - (bug "excluded case in INTERVAL-MUL")))))) + ;; Split x into two and multiply each separately + (destructuring-bind (x- x+) (interval-split 0 x t t) + (interval-merge-pair (interval-mul x- y) + (interval-mul x+ y)))) + ((null y-range) + ;; Split y into two and multiply each separately + (destructuring-bind (y- y+) (interval-split 0 y t t) + (interval-merge-pair (interval-mul x y-) + (interval-mul x y+)))) + ((eq x-range '-) + (interval-neg (interval-mul (interval-neg x) y))) + ((eq y-range '-) + (interval-neg (interval-mul x (interval-neg y)))) + ((and (eq x-range '+) (eq y-range '+)) + ;; If we are here, X and Y are both positive. + (make-interval + :low (bound-mul (interval-low x) (interval-low y)) + :high (bound-mul (interval-high x) (interval-high y)))) + (t + (bug "excluded case in INTERVAL-MUL")))))) ;;; Divide two intervals. (defun interval-div (top bot) (declare (type interval top bot)) (flet ((bound-div (x y y-low-p) - ;; Compute x/y - (cond ((null y) - ;; Divide by infinity means result is 0. However, - ;; we need to watch out for the sign of the result, - ;; to correctly handle signed zeros. We also need - ;; to watch out for positive or negative infinity. - (if (floatp (type-bound-number x)) - (if y-low-p - (- (float-sign (type-bound-number x) 0.0)) - (float-sign (type-bound-number x) 0.0)) - 0)) - ((zerop (type-bound-number y)) - ;; Divide by zero means result is infinity - nil) - ((and (numberp x) (zerop x)) - ;; Zero divided by anything is zero. - x) - (t - (bound-binop / x y))))) + ;; Compute x/y + (cond ((null y) + ;; Divide by infinity means result is 0. However, + ;; we need to watch out for the sign of the result, + ;; to correctly handle signed zeros. We also need + ;; to watch out for positive or negative infinity. + (if (floatp (type-bound-number x)) + (if y-low-p + (- (float-sign (type-bound-number x) 0.0)) + (float-sign (type-bound-number x) 0.0)) + 0)) + ((zerop (type-bound-number y)) + ;; Divide by zero means result is infinity + nil) + ((and (numberp x) (zerop x)) + ;; Zero divided by anything is zero. + x) + (t + (bound-binop / x y))))) (let ((top-range (interval-range-info top)) - (bot-range (interval-range-info bot))) + (bot-range (interval-range-info bot))) (cond ((null bot-range) - ;; The denominator contains zero, so anything goes! - (make-interval :low nil :high nil)) - ((eq bot-range '-) - ;; Denominator is negative so flip the sign, compute the - ;; result, and flip it back. - (interval-neg (interval-div top (interval-neg bot)))) - ((null top-range) - ;; Split top into two positive and negative parts, and - ;; divide each separately - (destructuring-bind (top- top+) (interval-split 0 top t t) - (interval-merge-pair (interval-div top- bot) - (interval-div top+ bot)))) - ((eq top-range '-) - ;; Top is negative so flip the sign, divide, and flip the - ;; sign of the result. - (interval-neg (interval-div (interval-neg top) bot))) - ((and (eq top-range '+) (eq bot-range '+)) - ;; the easy case - (make-interval - :low (bound-div (interval-low top) (interval-high bot) t) - :high (bound-div (interval-high top) (interval-low bot) nil))) - (t - (bug "excluded case in INTERVAL-DIV")))))) + ;; The denominator contains zero, so anything goes! + (make-interval :low nil :high nil)) + ((eq bot-range '-) + ;; Denominator is negative so flip the sign, compute the + ;; result, and flip it back. + (interval-neg (interval-div top (interval-neg bot)))) + ((null top-range) + ;; Split top into two positive and negative parts, and + ;; divide each separately + (destructuring-bind (top- top+) (interval-split 0 top t t) + (interval-merge-pair (interval-div top- bot) + (interval-div top+ bot)))) + ((eq top-range '-) + ;; Top is negative so flip the sign, divide, and flip the + ;; sign of the result. + (interval-neg (interval-div (interval-neg top) bot))) + ((and (eq top-range '+) (eq bot-range '+)) + ;; the easy case + (make-interval + :low (bound-div (interval-low top) (interval-high bot) t) + :high (bound-div (interval-high top) (interval-low bot) nil))) + (t + (bug "excluded case in INTERVAL-DIV")))))) ;;; Apply the function F to the interval X. If X = [a, b], then the ;;; result is [f(a), f(b)]. It is up to the user to make sure the @@ -692,7 +692,7 @@ (declare (type function f) (type interval x)) (let ((lo (bound-func f (interval-low x))) - (hi (bound-func f (interval-high x)))) + (hi (bound-func f (interval-high x)))) (make-interval :low lo :high hi))) ;;; Return T if X < Y. That is every number in the interval X is @@ -702,23 +702,23 @@ ;; X < Y only if X is bounded above, Y is bounded below, and they ;; don't overlap. (when (and (interval-bounded-p x 'above) - (interval-bounded-p y 'below)) + (interval-bounded-p y 'below)) ;; Intervals are bounded in the appropriate way. Make sure they ;; don't overlap. (let ((left (interval-high x)) - (right (interval-low y))) + (right (interval-low y))) (cond ((> (type-bound-number left) - (type-bound-number right)) - ;; The intervals definitely overlap, so result is NIL. - nil) - ((< (type-bound-number left) - (type-bound-number right)) - ;; The intervals definitely don't touch, so result is T. - t) - (t - ;; Limits are equal. Check for open or closed bounds. - ;; Don't overlap if one or the other are open. - (or (consp left) (consp right))))))) + (type-bound-number right)) + ;; The intervals definitely overlap, so result is NIL. + nil) + ((< (type-bound-number left) + (type-bound-number right)) + ;; The intervals definitely don't touch, so result is T. + t) + (t + ;; Limits are equal. Check for open or closed bounds. + ;; Don't overlap if one or the other are open. + (or (consp left) (consp right))))))) ;;; Return T if X >= Y. That is, every number in the interval X is ;;; always greater than any number in the interval Y. @@ -726,9 +726,9 @@ (declare (type interval x y)) ;; X >= Y if lower bound of X >= upper bound of Y (when (and (interval-bounded-p x 'below) - (interval-bounded-p y 'above)) + (interval-bounded-p y 'above)) (>= (type-bound-number (interval-low x)) - (type-bound-number (interval-high y))))) + (type-bound-number (interval-high y))))) ;;; Return an interval that is the absolute value of X. Thus, if ;;; X = [-1 10], the result is [0, 10]. @@ -747,7 +747,7 @@ (defun interval-sqr (x) (declare (type interval x)) (interval-func (lambda (x) (* x x)) - (interval-abs x))) + (interval-abs x))) ;;;; numeric DERIVE-TYPE methods @@ -758,29 +758,29 @@ (defun derive-integer-type-aux (x y fun) (declare (type function fun)) (if (and (numeric-type-p x) (numeric-type-p y) - (eq (numeric-type-class x) 'integer) - (eq (numeric-type-class y) 'integer) - (eq (numeric-type-complexp x) :real) - (eq (numeric-type-complexp y) :real)) + (eq (numeric-type-class x) 'integer) + (eq (numeric-type-class y) 'integer) + (eq (numeric-type-complexp x) :real) + (eq (numeric-type-complexp y) :real)) (multiple-value-bind (low high) (funcall fun x y) - (make-numeric-type :class 'integer - :complexp :real - :low low - :high high)) + (make-numeric-type :class 'integer + :complexp :real + :low low + :high high)) (numeric-contagion x y))) (defun derive-integer-type (x y fun) (declare (type lvar x y) (type function fun)) (let ((x (lvar-type x)) - (y (lvar-type y))) + (y (lvar-type y))) (derive-integer-type-aux x y fun))) ;;; simple utility to flatten a list (defun flatten-list (x) (labels ((flatten-and-append (tree list) - (cond ((null tree) list) - ((atom tree) (cons tree list)) - (t (flatten-and-append + (cond ((null tree) list) + ((atom tree) (cons tree list)) + (t (flatten-and-append (car tree) (flatten-and-append (cdr tree) list)))))) (flatten-and-append x nil))) @@ -789,30 +789,30 @@ ;;; failure. (defun prepare-arg-for-derive-type (arg) (flet ((listify (arg) - (typecase arg - (numeric-type - (list arg)) - (union-type - (union-type-types arg)) - (t - (list arg))))) + (typecase arg + (numeric-type + (list arg)) + (union-type + (union-type-types arg)) + (t + (list arg))))) (unless (eq arg *empty-type*) ;; Make sure all args are some type of numeric-type. For member ;; types, convert the list of members into a union of equivalent ;; single-element member-type's. (let ((new-args nil)) - (dolist (arg (listify arg)) - (if (member-type-p arg) - ;; Run down the list of members and convert to a list of - ;; member types. - (dolist (member (member-type-members arg)) - (push (if (numberp member) - (make-member-type :members (list member)) - *empty-type*) - new-args)) - (push arg new-args))) - (unless (member *empty-type* new-args) - new-args))))) + (dolist (arg (listify arg)) + (if (member-type-p arg) + ;; Run down the list of members and convert to a list of + ;; member types. + (dolist (member (member-type-members arg)) + (push (if (numberp member) + (make-member-type :members (list member)) + *empty-type*) + new-args)) + (push arg new-args))) + (unless (member *empty-type* new-args) + new-args))))) ;;; Convert from the standard type convention for which -0.0 and 0.0 ;;; are equal to an intermediate convention for which they are @@ -823,27 +823,27 @@ ;;; Only convert real float interval delimiters types. (if (eq (numeric-type-complexp type) :real) (let* ((lo (numeric-type-low type)) - (lo-val (type-bound-number lo)) - (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0))) - (hi (numeric-type-high type)) - (hi-val (type-bound-number hi)) - (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0)))) - (if (or lo-float-zero-p hi-float-zero-p) - (make-numeric-type - :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low (if lo-float-zero-p - (if (consp lo) - (list (float 0.0 lo-val)) - (float (load-time-value (make-unportable-float :single-float-negative-zero)) lo-val)) - lo) - :high (if hi-float-zero-p - (if (consp hi) - (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val)) - (float 0.0 hi-val)) - hi)) - type)) + (lo-val (type-bound-number lo)) + (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0))) + (hi (numeric-type-high type)) + (hi-val (type-bound-number hi)) + (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0)))) + (if (or lo-float-zero-p hi-float-zero-p) + (make-numeric-type + :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (if lo-float-zero-p + (if (consp lo) + (list (float 0.0 lo-val)) + (float (load-time-value (make-unportable-float :single-float-negative-zero)) lo-val)) + lo) + :high (if hi-float-zero-p + (if (consp hi) + (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val)) + (float 0.0 hi-val)) + hi)) + type)) ;; Not real float. type)) @@ -855,84 +855,84 @@ ;;; Only convert real float interval delimiters types. (if (eq (numeric-type-complexp type) :real) (let* ((lo (numeric-type-low type)) - (lo-val (type-bound-number lo)) - (lo-float-zero-p - (and lo (floatp lo-val) (= lo-val 0.0) - (float-sign lo-val))) - (hi (numeric-type-high type)) - (hi-val (type-bound-number hi)) - (hi-float-zero-p - (and hi (floatp hi-val) (= hi-val 0.0) - (float-sign hi-val)))) - (cond - ;; (float +0.0 +0.0) => (member 0.0) - ;; (float -0.0 -0.0) => (member -0.0) - ((and lo-float-zero-p hi-float-zero-p) - ;; shouldn't have exclusive bounds here.. - (aver (and (not (consp lo)) (not (consp hi)))) - (if (= lo-float-zero-p hi-float-zero-p) - ;; (float +0.0 +0.0) => (member 0.0) - ;; (float -0.0 -0.0) => (member -0.0) - (specifier-type `(member ,lo-val)) - ;; (float -0.0 +0.0) => (float 0.0 0.0) - ;; (float +0.0 -0.0) => (float 0.0 0.0) - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low hi-val - :high hi-val))) - (lo-float-zero-p - (cond - ;; (float -0.0 x) => (float 0.0 x) - ((and (not (consp lo)) (minusp lo-float-zero-p)) - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low (float 0.0 lo-val) - :high hi)) - ;; (float (+0.0) x) => (float (0.0) x) - ((and (consp lo) (plusp lo-float-zero-p)) - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low (list (float 0.0 lo-val)) - :high hi)) - (t - ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x)) - ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x)) - (list (make-member-type :members (list (float 0.0 lo-val))) - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low (list (float 0.0 lo-val)) - :high hi))))) - (hi-float-zero-p - (cond - ;; (float x +0.0) => (float x 0.0) - ((and (not (consp hi)) (plusp hi-float-zero-p)) - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low lo - :high (float 0.0 hi-val))) - ;; (float x (-0.0)) => (float x (0.0)) - ((and (consp hi) (minusp hi-float-zero-p)) - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low lo - :high (list (float 0.0 hi-val)))) - (t - ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0))) - ;; (float x -0.0) => (or (member -0.0) (float x (0.0))) - (list (make-member-type :members (list (float -0.0 hi-val))) - (make-numeric-type :class (numeric-type-class type) - :format (numeric-type-format type) - :complexp :real - :low lo - :high (list (float 0.0 hi-val))))))) - (t - type))) + (lo-val (type-bound-number lo)) + (lo-float-zero-p + (and lo (floatp lo-val) (= lo-val 0.0) + (float-sign lo-val))) + (hi (numeric-type-high type)) + (hi-val (type-bound-number hi)) + (hi-float-zero-p + (and hi (floatp hi-val) (= hi-val 0.0) + (float-sign hi-val)))) + (cond + ;; (float +0.0 +0.0) => (member 0.0) + ;; (float -0.0 -0.0) => (member -0.0) + ((and lo-float-zero-p hi-float-zero-p) + ;; shouldn't have exclusive bounds here.. + (aver (and (not (consp lo)) (not (consp hi)))) + (if (= lo-float-zero-p hi-float-zero-p) + ;; (float +0.0 +0.0) => (member 0.0) + ;; (float -0.0 -0.0) => (member -0.0) + (specifier-type `(member ,lo-val)) + ;; (float -0.0 +0.0) => (float 0.0 0.0) + ;; (float +0.0 -0.0) => (float 0.0 0.0) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low hi-val + :high hi-val))) + (lo-float-zero-p + (cond + ;; (float -0.0 x) => (float 0.0 x) + ((and (not (consp lo)) (minusp lo-float-zero-p)) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (float 0.0 lo-val) + :high hi)) + ;; (float (+0.0) x) => (float (0.0) x) + ((and (consp lo) (plusp lo-float-zero-p)) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (list (float 0.0 lo-val)) + :high hi)) + (t + ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x)) + ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x)) + (list (make-member-type :members (list (float 0.0 lo-val))) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (list (float 0.0 lo-val)) + :high hi))))) + (hi-float-zero-p + (cond + ;; (float x +0.0) => (float x 0.0) + ((and (not (consp hi)) (plusp hi-float-zero-p)) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low lo + :high (float 0.0 hi-val))) + ;; (float x (-0.0)) => (float x (0.0)) + ((and (consp hi) (minusp hi-float-zero-p)) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low lo + :high (list (float 0.0 hi-val)))) + (t + ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0))) + ;; (float x -0.0) => (or (member -0.0) (float x (0.0))) + (list (make-member-type :members (list (float -0.0 hi-val))) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low lo + :high (list (float 0.0 hi-val))))))) + (t + type))) ;; not real float type)) @@ -942,12 +942,12 @@ (list (let ((results '())) (dolist (type type-list) - (if (numeric-type-p type) - (let ((result (convert-back-numeric-type type))) - (if (listp result) - (setf results (append results result)) - (push result results))) - (push type results))) + (if (numeric-type-p type) + (let ((result (convert-back-numeric-type type))) + (if (listp result) + (setf results (append results result)) + (push result results))) + (push type results))) results)) (numeric-type (convert-back-numeric-type type-list)) @@ -969,11 +969,11 @@ ;;; member/number unions. (defun make-canonical-union-type (type-list) (let ((members '()) - (misc-types '())) + (misc-types '())) (dolist (type type-list) (if (member-type-p type) - (setf members (union members (member-type-members type))) - (push type misc-types))) + (setf members (union members (member-type-members type))) + (push type misc-types))) #!+long-float (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)) (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types) @@ -985,14 +985,14 @@ (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types) (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) (if members - (apply #'type-union (make-member-type :members members) misc-types) - (apply #'type-union misc-types)))) + (apply #'type-union (make-member-type :members members) misc-types) + (apply #'type-union misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) (let* ((members (member-type-members arg)) - (member (first members)) - (member-type (type-of member))) + (member (first members)) + (member-type (type-of member))) (aver (not (rest members))) (specifier-type (cond ((typep member 'integer) `(integer ,member ,member)) @@ -1015,44 +1015,44 @@ ;;; called to compute the result otherwise the member type is first ;;; converted to a numeric type and the DERIVE-FUN is called. (defun one-arg-derive-type (arg derive-fun member-fun - &optional (convert-type t)) + &optional (convert-type t)) (declare (type function derive-fun) - (type (or null function) member-fun)) + (type (or null function) member-fun)) (let ((arg-list (prepare-arg-for-derive-type (lvar-type arg)))) (when arg-list (flet ((deriver (x) - (typecase x - (member-type - (if member-fun - (with-float-traps-masked - (:underflow :overflow :divide-by-zero) - (specifier-type - `(eql ,(funcall member-fun - (first (member-type-members x)))))) - ;; Otherwise convert to a numeric type. - (let ((result-type-list - (funcall derive-fun (convert-member-type x)))) - (if convert-type - (convert-back-numeric-type-list result-type-list) - result-type-list)))) - (numeric-type - (if convert-type - (convert-back-numeric-type-list - (funcall derive-fun (convert-numeric-type x))) - (funcall derive-fun x))) - (t - *universal-type*)))) - ;; Run down the list of args and derive the type of each one, - ;; saving all of the results in a list. - (let ((results nil)) - (dolist (arg arg-list) - (let ((result (deriver arg))) - (if (listp result) - (setf results (append results result)) - (push result results)))) - (if (rest results) - (make-canonical-union-type results) - (first results))))))) + (typecase x + (member-type + (if member-fun + (with-float-traps-masked + (:underflow :overflow :divide-by-zero) + (specifier-type + `(eql ,(funcall member-fun + (first (member-type-members x)))))) + ;; Otherwise convert to a numeric type. + (let ((result-type-list + (funcall derive-fun (convert-member-type x)))) + (if convert-type + (convert-back-numeric-type-list result-type-list) + result-type-list)))) + (numeric-type + (if convert-type + (convert-back-numeric-type-list + (funcall derive-fun (convert-numeric-type x))) + (funcall derive-fun x))) + (t + *universal-type*)))) + ;; Run down the list of args and derive the type of each one, + ;; saving all of the results in a list. + (let ((results nil)) + (dolist (arg arg-list) + (let ((result (deriver arg))) + (if (listp result) + (setf results (append results result)) + (push result results)))) + (if (rest results) + (make-canonical-union-type results) + (first results))))))) ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes ;;; two arguments. DERIVE-FUN takes 3 args in this case: the two @@ -1061,71 +1061,71 @@ ;;; type of things like (* x x), which should always be positive. If ;;; we didn't do this, we wouldn't be able to tell. (defun two-arg-derive-type (arg1 arg2 derive-fun fun - &optional (convert-type t)) + &optional (convert-type t)) (declare (type function derive-fun fun)) (flet ((deriver (x y same-arg) - (cond ((and (member-type-p x) (member-type-p y)) - (let* ((x (first (member-type-members x))) - (y (first (member-type-members y))) - (result (ignore-errors + (cond ((and (member-type-p x) (member-type-p y)) + (let* ((x (first (member-type-members x))) + (y (first (member-type-members y))) + (result (ignore-errors (with-float-traps-masked (:underflow :overflow :divide-by-zero :invalid) (funcall fun x y))))) - (cond ((null result) *empty-type*) - ((and (floatp result) (float-nan-p result)) - (make-numeric-type :class 'float - :format (type-of result) - :complexp :real)) - (t - (specifier-type `(eql ,result)))))) - ((and (member-type-p x) (numeric-type-p y)) - (let* ((x (convert-member-type x)) - (y (if convert-type (convert-numeric-type y) y)) - (result (funcall derive-fun x y same-arg))) - (if convert-type - (convert-back-numeric-type-list result) - result))) - ((and (numeric-type-p x) (member-type-p y)) - (let* ((x (if convert-type (convert-numeric-type x) x)) - (y (convert-member-type y)) - (result (funcall derive-fun x y same-arg))) - (if convert-type - (convert-back-numeric-type-list result) - result))) - ((and (numeric-type-p x) (numeric-type-p y)) - (let* ((x (if convert-type (convert-numeric-type x) x)) - (y (if convert-type (convert-numeric-type y) y)) - (result (funcall derive-fun x y same-arg))) - (if convert-type - (convert-back-numeric-type-list result) - result))) - (t - *universal-type*)))) + (cond ((null result) *empty-type*) + ((and (floatp result) (float-nan-p result)) + (make-numeric-type :class 'float + :format (type-of result) + :complexp :real)) + (t + (specifier-type `(eql ,result)))))) + ((and (member-type-p x) (numeric-type-p y)) + (let* ((x (convert-member-type x)) + (y (if convert-type (convert-numeric-type y) y)) + (result (funcall derive-fun x y same-arg))) + (if convert-type + (convert-back-numeric-type-list result) + result))) + ((and (numeric-type-p x) (member-type-p y)) + (let* ((x (if convert-type (convert-numeric-type x) x)) + (y (convert-member-type y)) + (result (funcall derive-fun x y same-arg))) + (if convert-type + (convert-back-numeric-type-list result) + result))) + ((and (numeric-type-p x) (numeric-type-p y)) + (let* ((x (if convert-type (convert-numeric-type x) x)) + (y (if convert-type (convert-numeric-type y) y)) + (result (funcall derive-fun x y same-arg))) + (if convert-type + (convert-back-numeric-type-list result) + result))) + (t + *universal-type*)))) (let ((same-arg (same-leaf-ref-p arg1 arg2)) - (a1 (prepare-arg-for-derive-type (lvar-type arg1))) - (a2 (prepare-arg-for-derive-type (lvar-type arg2)))) + (a1 (prepare-arg-for-derive-type (lvar-type arg1))) + (a2 (prepare-arg-for-derive-type (lvar-type arg2)))) (when (and a1 a2) - (let ((results nil)) - (if same-arg - ;; Since the args are the same LVARs, just run down the - ;; lists. - (dolist (x a1) - (let ((result (deriver x x same-arg))) - (if (listp result) - (setf results (append results result)) - (push result results)))) - ;; Try all pairwise combinations. - (dolist (x a1) - (dolist (y a2) - (let ((result (or (deriver x y same-arg) - (numeric-contagion x y)))) - (if (listp result) - (setf results (append results result)) - (push result results)))))) - (if (rest results) - (make-canonical-union-type results) - (first results))))))) + (let ((results nil)) + (if same-arg + ;; Since the args are the same LVARs, just run down the + ;; lists. + (dolist (x a1) + (let ((result (deriver x x same-arg))) + (if (listp result) + (setf results (append results result)) + (push result results)))) + ;; Try all pairwise combinations. + (dolist (x a1) + (dolist (y a2) + (let ((result (or (deriver x y same-arg) + (numeric-contagion x y)))) + (if (listp result) + (setf results (append results result)) + (push result results)))))) + (if (rest results) + (make-canonical-union-type results) + (first results))))))) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn @@ -1134,44 +1134,44 @@ x y #'(lambda (x y) (flet ((frob (x y) - (if (and x y) - (+ x y) - nil))) - (values (frob (numeric-type-low x) (numeric-type-low y)) - (frob (numeric-type-high x) (numeric-type-high y))))))) + (if (and x y) + (+ x y) + nil))) + (values (frob (numeric-type-low x) (numeric-type-low y)) + (frob (numeric-type-high x) (numeric-type-high y))))))) (defoptimizer (- derive-type) ((x y)) (derive-integer-type x y #'(lambda (x y) (flet ((frob (x y) - (if (and x y) - (- x y) - nil))) - (values (frob (numeric-type-low x) (numeric-type-high y)) - (frob (numeric-type-high x) (numeric-type-low y))))))) + (if (and x y) + (- x y) + nil))) + (values (frob (numeric-type-low x) (numeric-type-high y)) + (frob (numeric-type-high x) (numeric-type-low y))))))) (defoptimizer (* derive-type) ((x y)) (derive-integer-type x y #'(lambda (x y) (let ((x-low (numeric-type-low x)) - (x-high (numeric-type-high x)) - (y-low (numeric-type-low y)) - (y-high (numeric-type-high y))) - (cond ((not (and x-low y-low)) - (values nil nil)) - ((or (minusp x-low) (minusp y-low)) - (if (and x-high y-high) - (let ((max (* (max (abs x-low) (abs x-high)) - (max (abs y-low) (abs y-high))))) - (values (- max) max)) - (values nil nil))) - (t - (values (* x-low y-low) - (if (and x-high y-high) - (* x-high y-high) - nil)))))))) + (x-high (numeric-type-high x)) + (y-low (numeric-type-low y)) + (y-high (numeric-type-high y))) + (cond ((not (and x-low y-low)) + (values nil nil)) + ((or (minusp x-low) (minusp y-low)) + (if (and x-high y-high) + (let ((max (* (max (abs x-low) (abs x-high)) + (max (abs y-low) (abs y-high))))) + (values (- max) max)) + (values nil nil))) + (t + (values (* x-low y-low) + (if (and x-high y-high) + (* x-high y-high) + nil)))))))) (defoptimizer (/ derive-type) ((x y)) (numeric-contagion (lvar-type x) (lvar-type y))) @@ -1182,31 +1182,31 @@ (progn (defun +-derive-type-aux (x y same-arg) (if (and (numeric-type-real-p x) - (numeric-type-real-p y)) + (numeric-type-real-p y)) (let ((result - (if same-arg - (let ((x-int (numeric-type->interval x))) - (interval-add x-int x-int)) - (interval-add (numeric-type->interval x) - (numeric-type->interval y)))) - (result-type (numeric-contagion x y))) - ;; If the result type is a float, we need to be sure to coerce - ;; the bounds into the correct type. - (when (eq (numeric-type-class result-type) 'float) - (setf result (interval-func - #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) - result))) - (make-numeric-type - :class (if (and (eq (numeric-type-class x) 'integer) - (eq (numeric-type-class y) 'integer)) - ;; The sum of integers is always an integer. - 'integer - (numeric-type-class result-type)) - :format (numeric-type-format result-type) - :low (interval-low result) - :high (interval-high result))) + (if same-arg + (let ((x-int (numeric-type->interval x))) + (interval-add x-int x-int)) + (interval-add (numeric-type->interval x) + (numeric-type->interval y)))) + (result-type (numeric-contagion x y))) + ;; If the result type is a float, we need to be sure to coerce + ;; the bounds into the correct type. + (when (eq (numeric-type-class result-type) 'float) + (setf result (interval-func + #'(lambda (x) + (coerce x (or (numeric-type-format result-type) + 'float))) + result))) + (make-numeric-type + :class (if (and (eq (numeric-type-class x) 'integer) + (eq (numeric-type-class y) 'integer)) + ;; The sum of integers is always an integer. + 'integer + (numeric-type-class result-type)) + :format (numeric-type-format result-type) + :low (interval-low result) + :high (interval-high result))) ;; general contagion (numeric-contagion x y))) @@ -1215,31 +1215,31 @@ (defun --derive-type-aux (x y same-arg) (if (and (numeric-type-real-p x) - (numeric-type-real-p y)) + (numeric-type-real-p y)) (let ((result - ;; (- X X) is always 0. - (if same-arg - (make-interval :low 0 :high 0) - (interval-sub (numeric-type->interval x) - (numeric-type->interval y)))) - (result-type (numeric-contagion x y))) - ;; If the result type is a float, we need to be sure to coerce - ;; the bounds into the correct type. - (when (eq (numeric-type-class result-type) 'float) - (setf result (interval-func - #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) - result))) - (make-numeric-type - :class (if (and (eq (numeric-type-class x) 'integer) - (eq (numeric-type-class y) 'integer)) - ;; The difference of integers is always an integer. - 'integer - (numeric-type-class result-type)) - :format (numeric-type-format result-type) - :low (interval-low result) - :high (interval-high result))) + ;; (- X X) is always 0. + (if same-arg + (make-interval :low 0 :high 0) + (interval-sub (numeric-type->interval x) + (numeric-type->interval y)))) + (result-type (numeric-contagion x y))) + ;; If the result type is a float, we need to be sure to coerce + ;; the bounds into the correct type. + (when (eq (numeric-type-class result-type) 'float) + (setf result (interval-func + #'(lambda (x) + (coerce x (or (numeric-type-format result-type) + 'float))) + result))) + (make-numeric-type + :class (if (and (eq (numeric-type-class x) 'integer) + (eq (numeric-type-class y) 'integer)) + ;; The difference of integers is always an integer. + 'integer + (numeric-type-class result-type)) + :format (numeric-type-format result-type) + :low (interval-low result) + :high (interval-high result))) ;; general contagion (numeric-contagion x y))) @@ -1248,31 +1248,31 @@ (defun *-derive-type-aux (x y same-arg) (if (and (numeric-type-real-p x) - (numeric-type-real-p y)) + (numeric-type-real-p y)) (let ((result - ;; (* X X) is always positive, so take care to do it right. - (if same-arg - (interval-sqr (numeric-type->interval x)) - (interval-mul (numeric-type->interval x) - (numeric-type->interval y)))) - (result-type (numeric-contagion x y))) - ;; If the result type is a float, we need to be sure to coerce - ;; the bounds into the correct type. - (when (eq (numeric-type-class result-type) 'float) - (setf result (interval-func - #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) - result))) - (make-numeric-type - :class (if (and (eq (numeric-type-class x) 'integer) - (eq (numeric-type-class y) 'integer)) - ;; The product of integers is always an integer. - 'integer - (numeric-type-class result-type)) - :format (numeric-type-format result-type) - :low (interval-low result) - :high (interval-high result))) + ;; (* X X) is always positive, so take care to do it right. + (if same-arg + (interval-sqr (numeric-type->interval x)) + (interval-mul (numeric-type->interval x) + (numeric-type->interval y)))) + (result-type (numeric-contagion x y))) + ;; If the result type is a float, we need to be sure to coerce + ;; the bounds into the correct type. + (when (eq (numeric-type-class result-type) 'float) + (setf result (interval-func + #'(lambda (x) + (coerce x (or (numeric-type-format result-type) + 'float))) + result))) + (make-numeric-type + :class (if (and (eq (numeric-type-class x) 'integer) + (eq (numeric-type-class y) 'integer)) + ;; The product of integers is always an integer. + 'integer + (numeric-type-class result-type)) + :format (numeric-type-format result-type) + :low (interval-low result) + :high (interval-high result))) (numeric-contagion x y))) (defoptimizer (* derive-type) ((x y)) @@ -1280,30 +1280,30 @@ (defun /-derive-type-aux (x y same-arg) (if (and (numeric-type-real-p x) - (numeric-type-real-p y)) + (numeric-type-real-p y)) (let ((result - ;; (/ X X) is always 1, except if X can contain 0. In - ;; that case, we shouldn't optimize the division away - ;; because we want 0/0 to signal an error. - (if (and same-arg - (not (interval-contains-p - 0 (interval-closure (numeric-type->interval y))))) - (make-interval :low 1 :high 1) - (interval-div (numeric-type->interval x) - (numeric-type->interval y)))) - (result-type (numeric-contagion x y))) - ;; If the result type is a float, we need to be sure to coerce - ;; the bounds into the correct type. - (when (eq (numeric-type-class result-type) 'float) - (setf result (interval-func - #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) - result))) - (make-numeric-type :class (numeric-type-class result-type) - :format (numeric-type-format result-type) - :low (interval-low result) - :high (interval-high result))) + ;; (/ X X) is always 1, except if X can contain 0. In + ;; that case, we shouldn't optimize the division away + ;; because we want 0/0 to signal an error. + (if (and same-arg + (not (interval-contains-p + 0 (interval-closure (numeric-type->interval y))))) + (make-interval :low 1 :high 1) + (interval-div (numeric-type->interval x) + (numeric-type->interval y)))) + (result-type (numeric-contagion x y))) + ;; If the result type is a float, we need to be sure to coerce + ;; the bounds into the correct type. + (when (eq (numeric-type-class result-type) 'float) + (setf result (interval-func + #'(lambda (x) + (coerce x (or (numeric-type-format result-type) + 'float))) + result))) + (make-numeric-type :class (numeric-type-class result-type) + :format (numeric-type-format result-type) + :low (interval-low result) + :high (interval-high result))) (numeric-contagion x y))) (defoptimizer (/ derive-type) ((x y)) @@ -1320,64 +1320,64 @@ ;; calculation in here. #+(and cmu sb-xc-host) (when (and (or (typep (numeric-type-low n-type) 'bignum) - (typep (numeric-type-high n-type) 'bignum)) - (or (typep (numeric-type-low shift) 'bignum) - (typep (numeric-type-high shift) 'bignum))) + (typep (numeric-type-high n-type) 'bignum)) + (or (typep (numeric-type-low shift) 'bignum) + (typep (numeric-type-high shift) 'bignum))) (return-from ash-derive-type-aux *universal-type*)) (flet ((ash-outer (n s) - (when (and (fixnump s) - (<= s 64) - (> s sb!xc:most-negative-fixnum)) - (ash n s))) + (when (and (fixnump s) + (<= s 64) + (> s sb!xc:most-negative-fixnum)) + (ash n s))) ;; KLUDGE: The bare 64's here should be related to ;; symbolic machine word size values somehow. - (ash-inner (n s) - (if (and (fixnump s) - (> s sb!xc:most-negative-fixnum)) + (ash-inner (n s) + (if (and (fixnump s) + (> s sb!xc:most-negative-fixnum)) (ash n (min s 64)) (if (minusp n) -1 0)))) (or (and (csubtypep n-type (specifier-type 'integer)) - (csubtypep shift (specifier-type 'integer)) - (let ((n-low (numeric-type-low n-type)) - (n-high (numeric-type-high n-type)) - (s-low (numeric-type-low shift)) - (s-high (numeric-type-high shift))) - (make-numeric-type :class 'integer :complexp :real - :low (when n-low - (if (minusp n-low) + (csubtypep shift (specifier-type 'integer)) + (let ((n-low (numeric-type-low n-type)) + (n-high (numeric-type-high n-type)) + (s-low (numeric-type-low shift)) + (s-high (numeric-type-high shift))) + (make-numeric-type :class 'integer :complexp :real + :low (when n-low + (if (minusp n-low) (ash-outer n-low s-high) (ash-inner n-low s-low))) - :high (when n-high - (if (minusp n-high) + :high (when n-high + (if (minusp n-high) (ash-inner n-high s-low) (ash-outer n-high s-high)))))) - *universal-type*))) + *universal-type*))) (defoptimizer (ash derive-type) ((n shift)) (two-arg-derive-type n shift #'ash-derive-type-aux #'ash)) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (macrolet ((frob (fun) - `#'(lambda (type type2) - (declare (ignore type2)) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (values (if hi (,fun hi) nil) (if lo (,fun lo) nil)))))) + `#'(lambda (type type2) + (declare (ignore type2)) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (values (if hi (,fun hi) nil) (if lo (,fun lo) nil)))))) (defoptimizer (%negate derive-type) ((num)) (derive-integer-type num num (frob -)))) (defun lognot-derive-type-aux (int) (derive-integer-type-aux int int - (lambda (type type2) - (declare (ignore type2)) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (values (if hi (lognot hi) nil) - (if lo (lognot lo) nil) - (numeric-type-class type) - (numeric-type-format type)))))) + (lambda (type type2) + (declare (ignore type2)) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (values (if hi (lognot hi) nil) + (if lo (lognot lo) nil) + (numeric-type-class type) + (numeric-type-format type)))))) (defoptimizer (lognot derive-type) ((int)) (lognot-derive-type-aux (lvar-type int))) @@ -1386,64 +1386,64 @@ (defoptimizer (%negate derive-type) ((num)) (flet ((negate-bound (b) (and b - (set-bound (- (type-bound-number b)) - (consp b))))) + (set-bound (- (type-bound-number b)) + (consp b))))) (one-arg-derive-type num - (lambda (type) - (modified-numeric-type - type - :low (negate-bound (numeric-type-high type)) - :high (negate-bound (numeric-type-low type)))) - #'-))) + (lambda (type) + (modified-numeric-type + type + :low (negate-bound (numeric-type-high type)) + :high (negate-bound (numeric-type-low type)))) + #'-))) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (abs derive-type) ((num)) (let ((type (lvar-type num))) (if (and (numeric-type-p type) - (eq (numeric-type-class type) 'integer) - (eq (numeric-type-complexp type) :real)) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (make-numeric-type :class 'integer :complexp :real - :low (cond ((and hi (minusp hi)) - (abs hi)) - (lo - (max 0 lo)) - (t - 0)) - :high (if (and hi lo) - (max (abs hi) (abs lo)) - nil))) - (numeric-contagion type type)))) + (eq (numeric-type-class type) 'integer) + (eq (numeric-type-complexp type) :real)) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (make-numeric-type :class 'integer :complexp :real + :low (cond ((and hi (minusp hi)) + (abs hi)) + (lo + (max 0 lo)) + (t + 0)) + :high (if (and hi lo) + (max (abs hi) (abs lo)) + nil))) + (numeric-contagion type type)))) #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun abs-derive-type-aux (type) (cond ((eq (numeric-type-complexp type) :complex) - ;; The absolute value of a complex number is always a - ;; non-negative float. - (let* ((format (case (numeric-type-class type) - ((integer rational) 'single-float) - (t (numeric-type-format type)))) - (bound-format (or format 'float))) - (make-numeric-type :class 'float - :format format - :complexp :real - :low (coerce 0 bound-format) - :high nil))) - (t - ;; The absolute value of a real number is a non-negative real - ;; of the same type. - (let* ((abs-bnd (interval-abs (numeric-type->interval type))) - (class (numeric-type-class type)) - (format (numeric-type-format type)) - (bound-type (or format class 'real))) - (make-numeric-type - :class class - :format format - :complexp :real - :low (coerce-numeric-bound (interval-low abs-bnd) bound-type) - :high (coerce-numeric-bound - (interval-high abs-bnd) bound-type)))))) + ;; The absolute value of a complex number is always a + ;; non-negative float. + (let* ((format (case (numeric-type-class type) + ((integer rational) 'single-float) + (t (numeric-type-format type)))) + (bound-format (or format 'float))) + (make-numeric-type :class 'float + :format format + :complexp :real + :low (coerce 0 bound-format) + :high nil))) + (t + ;; The absolute value of a real number is a non-negative real + ;; of the same type. + (let* ((abs-bnd (interval-abs (numeric-type->interval type))) + (class (numeric-type-class type)) + (format (numeric-type-format type)) + (bound-type (or format class 'real))) + (make-numeric-type + :class class + :format format + :complexp :real + :low (coerce-numeric-bound (interval-low abs-bnd) bound-type) + :high (coerce-numeric-bound + (interval-high abs-bnd) bound-type)))))) #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (abs derive-type) ((num)) @@ -1452,22 +1452,22 @@ #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (truncate derive-type) ((number divisor)) (let ((number-type (lvar-type number)) - (divisor-type (lvar-type divisor)) - (integer-type (specifier-type 'integer))) + (divisor-type (lvar-type divisor)) + (integer-type (specifier-type 'integer))) (if (and (numeric-type-p number-type) - (csubtypep number-type integer-type) - (numeric-type-p divisor-type) - (csubtypep divisor-type integer-type)) - (let ((number-low (numeric-type-low number-type)) - (number-high (numeric-type-high number-type)) - (divisor-low (numeric-type-low divisor-type)) - (divisor-high (numeric-type-high divisor-type))) - (values-specifier-type - `(values ,(integer-truncate-derive-type number-low number-high - divisor-low divisor-high) - ,(integer-rem-derive-type number-low number-high - divisor-low divisor-high)))) - *universal-type*))) + (csubtypep number-type integer-type) + (numeric-type-p divisor-type) + (csubtypep divisor-type integer-type)) + (let ((number-low (numeric-type-low number-type)) + (number-high (numeric-type-high number-type)) + (divisor-low (numeric-type-low divisor-type)) + (divisor-high (numeric-type-high divisor-type))) + (values-specifier-type + `(values ,(integer-truncate-derive-type number-low number-high + divisor-low divisor-high) + ,(integer-rem-derive-type number-low number-high + divisor-low divisor-high)))) + *universal-type*))) #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn @@ -1477,111 +1477,111 @@ ;; integer if both args are integers; a rational if both args are ;; rational; and a float otherwise. (cond ((and (csubtypep number-type (specifier-type 'integer)) - (csubtypep divisor-type (specifier-type 'integer))) - 'integer) - ((and (csubtypep number-type (specifier-type 'rational)) - (csubtypep divisor-type (specifier-type 'rational))) - 'rational) - ((and (csubtypep number-type (specifier-type 'float)) - (csubtypep divisor-type (specifier-type 'float))) - ;; Both are floats so the result is also a float, of - ;; the largest type. - (or (float-format-max (numeric-type-format number-type) - (numeric-type-format divisor-type)) - 'float)) - ((and (csubtypep number-type (specifier-type 'float)) - (csubtypep divisor-type (specifier-type 'rational))) - ;; One of the arguments is a float and the other is a - ;; rational. The remainder is a float of the same - ;; type. - (or (numeric-type-format number-type) 'float)) - ((and (csubtypep divisor-type (specifier-type 'float)) - (csubtypep number-type (specifier-type 'rational))) - ;; One of the arguments is a float and the other is a - ;; rational. The remainder is a float of the same - ;; type. - (or (numeric-type-format divisor-type) 'float)) - (t - ;; Some unhandled combination. This usually means both args - ;; are REAL so the result is a REAL. - 'real))) + (csubtypep divisor-type (specifier-type 'integer))) + 'integer) + ((and (csubtypep number-type (specifier-type 'rational)) + (csubtypep divisor-type (specifier-type 'rational))) + 'rational) + ((and (csubtypep number-type (specifier-type 'float)) + (csubtypep divisor-type (specifier-type 'float))) + ;; Both are floats so the result is also a float, of + ;; the largest type. + (or (float-format-max (numeric-type-format number-type) + (numeric-type-format divisor-type)) + 'float)) + ((and (csubtypep number-type (specifier-type 'float)) + (csubtypep divisor-type (specifier-type 'rational))) + ;; One of the arguments is a float and the other is a + ;; rational. The remainder is a float of the same + ;; type. + (or (numeric-type-format number-type) 'float)) + ((and (csubtypep divisor-type (specifier-type 'float)) + (csubtypep number-type (specifier-type 'rational))) + ;; One of the arguments is a float and the other is a + ;; rational. The remainder is a float of the same + ;; type. + (or (numeric-type-format divisor-type) 'float)) + (t + ;; Some unhandled combination. This usually means both args + ;; are REAL so the result is a REAL. + 'real))) (defun truncate-derive-type-quot (number-type divisor-type) (let* ((rem-type (rem-result-type number-type divisor-type)) - (number-interval (numeric-type->interval number-type)) - (divisor-interval (numeric-type->interval divisor-type))) + (number-interval (numeric-type->interval number-type)) + (divisor-interval (numeric-type->interval divisor-type))) ;;(declare (type (member '(integer rational float)) rem-type)) ;; We have real numbers now. (cond ((eq rem-type 'integer) - ;; Since the remainder type is INTEGER, both args are - ;; INTEGERs. - (let* ((res (integer-truncate-derive-type - (interval-low number-interval) - (interval-high number-interval) - (interval-low divisor-interval) - (interval-high divisor-interval)))) - (specifier-type (if (listp res) res 'integer)))) - (t - (let ((quot (truncate-quotient-bound - (interval-div number-interval - divisor-interval)))) - (specifier-type `(integer ,(or (interval-low quot) '*) - ,(or (interval-high quot) '*)))))))) + ;; Since the remainder type is INTEGER, both args are + ;; INTEGERs. + (let* ((res (integer-truncate-derive-type + (interval-low number-interval) + (interval-high number-interval) + (interval-low divisor-interval) + (interval-high divisor-interval)))) + (specifier-type (if (listp res) res 'integer)))) + (t + (let ((quot (truncate-quotient-bound + (interval-div number-interval + divisor-interval)))) + (specifier-type `(integer ,(or (interval-low quot) '*) + ,(or (interval-high quot) '*)))))))) (defun truncate-derive-type-rem (number-type divisor-type) (let* ((rem-type (rem-result-type number-type divisor-type)) - (number-interval (numeric-type->interval number-type)) - (divisor-interval (numeric-type->interval divisor-type)) - (rem (truncate-rem-bound number-interval divisor-interval))) + (number-interval (numeric-type->interval number-type)) + (divisor-interval (numeric-type->interval divisor-type)) + (rem (truncate-rem-bound number-interval divisor-interval))) ;;(declare (type (member '(integer rational float)) rem-type)) ;; We have real numbers now. (cond ((eq rem-type 'integer) - ;; Since the remainder type is INTEGER, both args are - ;; INTEGERs. - (specifier-type `(,rem-type ,(or (interval-low rem) '*) - ,(or (interval-high rem) '*)))) - (t - (multiple-value-bind (class format) - (ecase rem-type - (integer - (values 'integer nil)) - (rational - (values 'rational nil)) - ((or single-float double-float #!+long-float long-float) - (values 'float rem-type)) - (float - (values 'float nil)) - (real - (values nil nil))) - (when (member rem-type '(float single-float double-float - #!+long-float long-float)) - (setf rem (interval-func #'(lambda (x) - (coerce x rem-type)) - rem))) - (make-numeric-type :class class - :format format - :low (interval-low rem) - :high (interval-high rem))))))) + ;; Since the remainder type is INTEGER, both args are + ;; INTEGERs. + (specifier-type `(,rem-type ,(or (interval-low rem) '*) + ,(or (interval-high rem) '*)))) + (t + (multiple-value-bind (class format) + (ecase rem-type + (integer + (values 'integer nil)) + (rational + (values 'rational nil)) + ((or single-float double-float #!+long-float long-float) + (values 'float rem-type)) + (float + (values 'float nil)) + (real + (values nil nil))) + (when (member rem-type '(float single-float double-float + #!+long-float long-float)) + (setf rem (interval-func #'(lambda (x) + (coerce x rem-type)) + rem))) + (make-numeric-type :class class + :format format + :low (interval-low rem) + :high (interval-high rem))))))) (defun truncate-derive-type-quot-aux (num div same-arg) (declare (ignore same-arg)) (if (and (numeric-type-real-p num) - (numeric-type-real-p div)) + (numeric-type-real-p div)) (truncate-derive-type-quot num div) *empty-type*)) (defun truncate-derive-type-rem-aux (num div same-arg) (declare (ignore same-arg)) (if (and (numeric-type-real-p num) - (numeric-type-real-p div)) + (numeric-type-real-p div)) (truncate-derive-type-rem num div) *empty-type*)) (defoptimizer (truncate derive-type) ((number divisor)) (let ((quot (two-arg-derive-type number divisor - #'truncate-derive-type-quot-aux #'truncate)) - (rem (two-arg-derive-type number divisor - #'truncate-derive-type-rem-aux #'rem))) + #'truncate-derive-type-quot-aux #'truncate)) + (rem (two-arg-derive-type number divisor + #'truncate-derive-type-rem-aux #'rem))) (when (and quot rem) (make-values-type :required (list quot rem))))) @@ -1590,25 +1590,25 @@ ;; result is a float of some type. We need to determine what that ;; type is. Basically it's the more contagious of the two types. (let ((q-type (truncate-derive-type-quot number-type divisor-type)) - (res-type (numeric-contagion number-type divisor-type))) + (res-type (numeric-contagion number-type divisor-type))) (make-numeric-type :class 'float - :format (numeric-type-format res-type) - :low (numeric-type-low q-type) - :high (numeric-type-high q-type)))) + :format (numeric-type-format res-type) + :low (numeric-type-low q-type) + :high (numeric-type-high q-type)))) (defun ftruncate-derive-type-quot-aux (n d same-arg) (declare (ignore same-arg)) (if (and (numeric-type-real-p n) - (numeric-type-real-p d)) + (numeric-type-real-p d)) (ftruncate-derive-type-quot n d) *empty-type*)) (defoptimizer (ftruncate derive-type) ((number divisor)) (let ((quot - (two-arg-derive-type number divisor - #'ftruncate-derive-type-quot-aux #'ftruncate)) - (rem (two-arg-derive-type number divisor - #'truncate-derive-type-rem-aux #'rem))) + (two-arg-derive-type number divisor + #'ftruncate-derive-type-quot-aux #'ftruncate)) + (rem (two-arg-derive-type number divisor + #'truncate-derive-type-rem-aux #'rem))) (when (and quot rem) (make-values-type :required (list quot rem))))) @@ -1617,8 +1617,8 @@ (defoptimizer (%unary-truncate derive-type) ((number)) (one-arg-derive-type number - #'%unary-truncate-derive-type-aux - #'%unary-truncate)) + #'%unary-truncate-derive-type-aux + #'%unary-truncate)) (defoptimizer (%unary-ftruncate derive-type) ((number)) (let ((divisor (specifier-type '(integer 1 1)))) @@ -1631,111 +1631,111 @@ (macrolet ((def (name q-name r-name) (let ((q-aux (symbolicate q-name "-AUX")) - (r-aux (symbolicate r-name "-AUX"))) - `(progn - ;; Compute type of quotient (first) result. - (defun ,q-aux (number-type divisor-type) - (let* ((number-interval - (numeric-type->interval number-type)) - (divisor-interval - (numeric-type->interval divisor-type)) - (quot (,q-name (interval-div number-interval - divisor-interval)))) - (specifier-type `(integer ,(or (interval-low quot) '*) - ,(or (interval-high quot) '*))))) - ;; Compute type of remainder. - (defun ,r-aux (number-type divisor-type) - (let* ((divisor-interval - (numeric-type->interval divisor-type)) - (rem (,r-name divisor-interval)) - (result-type (rem-result-type number-type divisor-type))) - (multiple-value-bind (class format) - (ecase result-type - (integer - (values 'integer nil)) - (rational - (values 'rational nil)) - ((or single-float double-float #!+long-float long-float) - (values 'float result-type)) - (float - (values 'float nil)) - (real - (values nil nil))) - (when (member result-type '(float single-float double-float - #!+long-float long-float)) - ;; Make sure that the limits on the interval have - ;; the right type. - (setf rem (interval-func (lambda (x) - (coerce x result-type)) - rem))) - (make-numeric-type :class class - :format format - :low (interval-low rem) - :high (interval-high rem))))) - ;; the optimizer itself - (defoptimizer (,name derive-type) ((number divisor)) - (flet ((derive-q (n d same-arg) - (declare (ignore same-arg)) - (if (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (,q-aux n d) - *empty-type*)) - (derive-r (n d same-arg) - (declare (ignore same-arg)) - (if (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (,r-aux n d) - *empty-type*))) - (let ((quot (two-arg-derive-type - number divisor #'derive-q #',name)) - (rem (two-arg-derive-type - number divisor #'derive-r #'mod))) - (when (and quot rem) - (make-values-type :required (list quot rem)))))))))) + (r-aux (symbolicate r-name "-AUX"))) + `(progn + ;; Compute type of quotient (first) result. + (defun ,q-aux (number-type divisor-type) + (let* ((number-interval + (numeric-type->interval number-type)) + (divisor-interval + (numeric-type->interval divisor-type)) + (quot (,q-name (interval-div number-interval + divisor-interval)))) + (specifier-type `(integer ,(or (interval-low quot) '*) + ,(or (interval-high quot) '*))))) + ;; Compute type of remainder. + (defun ,r-aux (number-type divisor-type) + (let* ((divisor-interval + (numeric-type->interval divisor-type)) + (rem (,r-name divisor-interval)) + (result-type (rem-result-type number-type divisor-type))) + (multiple-value-bind (class format) + (ecase result-type + (integer + (values 'integer nil)) + (rational + (values 'rational nil)) + ((or single-float double-float #!+long-float long-float) + (values 'float result-type)) + (float + (values 'float nil)) + (real + (values nil nil))) + (when (member result-type '(float single-float double-float + #!+long-float long-float)) + ;; Make sure that the limits on the interval have + ;; the right type. + (setf rem (interval-func (lambda (x) + (coerce x result-type)) + rem))) + (make-numeric-type :class class + :format format + :low (interval-low rem) + :high (interval-high rem))))) + ;; the optimizer itself + (defoptimizer (,name derive-type) ((number divisor)) + (flet ((derive-q (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,q-aux n d) + *empty-type*)) + (derive-r (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,r-aux n d) + *empty-type*))) + (let ((quot (two-arg-derive-type + number divisor #'derive-q #',name)) + (rem (two-arg-derive-type + number divisor #'derive-r #'mod))) + (when (and quot rem) + (make-values-type :required (list quot rem)))))))))) (def floor floor-quotient-bound floor-rem-bound) (def ceiling ceiling-quotient-bound ceiling-rem-bound)) ;;; Define optimizers for FFLOOR and FCEILING (macrolet ((def (name q-name r-name) - (let ((q-aux (symbolicate "F" q-name "-AUX")) - (r-aux (symbolicate r-name "-AUX"))) - `(progn - ;; Compute type of quotient (first) result. - (defun ,q-aux (number-type divisor-type) - (let* ((number-interval - (numeric-type->interval number-type)) - (divisor-interval - (numeric-type->interval divisor-type)) - (quot (,q-name (interval-div number-interval - divisor-interval))) - (res-type (numeric-contagion number-type - divisor-type))) - (make-numeric-type - :class (numeric-type-class res-type) - :format (numeric-type-format res-type) - :low (interval-low quot) - :high (interval-high quot)))) - - (defoptimizer (,name derive-type) ((number divisor)) - (flet ((derive-q (n d same-arg) - (declare (ignore same-arg)) - (if (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (,q-aux n d) - *empty-type*)) - (derive-r (n d same-arg) - (declare (ignore same-arg)) - (if (and (numeric-type-real-p n) - (numeric-type-real-p d)) - (,r-aux n d) - *empty-type*))) - (let ((quot (two-arg-derive-type - number divisor #'derive-q #',name)) - (rem (two-arg-derive-type - number divisor #'derive-r #'mod))) - (when (and quot rem) - (make-values-type :required (list quot rem)))))))))) + (let ((q-aux (symbolicate "F" q-name "-AUX")) + (r-aux (symbolicate r-name "-AUX"))) + `(progn + ;; Compute type of quotient (first) result. + (defun ,q-aux (number-type divisor-type) + (let* ((number-interval + (numeric-type->interval number-type)) + (divisor-interval + (numeric-type->interval divisor-type)) + (quot (,q-name (interval-div number-interval + divisor-interval))) + (res-type (numeric-contagion number-type + divisor-type))) + (make-numeric-type + :class (numeric-type-class res-type) + :format (numeric-type-format res-type) + :low (interval-low quot) + :high (interval-high quot)))) + + (defoptimizer (,name derive-type) ((number divisor)) + (flet ((derive-q (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,q-aux n d) + *empty-type*)) + (derive-r (n d same-arg) + (declare (ignore same-arg)) + (if (and (numeric-type-real-p n) + (numeric-type-real-p d)) + (,r-aux n d) + *empty-type*))) + (let ((quot (two-arg-derive-type + number divisor #'derive-q #',name)) + (rem (two-arg-derive-type + number divisor #'derive-r #'mod))) + (when (and quot rem) + (make-values-type :required (list quot rem)))))))))) (def ffloor floor-quotient-bound floor-rem-bound) (def fceiling ceiling-quotient-bound ceiling-rem-bound)) @@ -1746,27 +1746,27 @@ ;; Take the floor of the quotient and then massage it into what we ;; need. (let ((lo (interval-low quot)) - (hi (interval-high quot))) + (hi (interval-high quot))) ;; Take the floor of the lower bound. The result is always a ;; closed lower bound. (setf lo (if lo - (floor (type-bound-number lo)) - nil)) + (floor (type-bound-number lo)) + nil)) ;; For the upper bound, we need to be careful. (setf hi - (cond ((consp hi) - ;; An open bound. We need to be careful here because - ;; the floor of '(10.0) is 9, but the floor of - ;; 10.0 is 10. - (multiple-value-bind (q r) (floor (first hi)) - (if (zerop r) - (1- q) - q))) - (hi - ;; A closed bound, so the answer is obvious. - (floor hi)) - (t - hi))) + (cond ((consp hi) + ;; An open bound. We need to be careful here because + ;; the floor of '(10.0) is 9, but the floor of + ;; 10.0 is 10. + (multiple-value-bind (q r) (floor (first hi)) + (if (zerop r) + (1- q) + q))) + (hi + ;; A closed bound, so the answer is obvious. + (floor hi)) + (t + hi))) (make-interval :low lo :high hi))) (defun floor-rem-bound (div) ;; The remainder depends only on the divisor. Try to get the @@ -1777,18 +1777,18 @@ (let ((rem (interval-abs div))) (setf (interval-low rem) 0) (when (and (numberp (interval-high rem)) - (not (zerop (interval-high rem)))) - ;; The remainder never contains the upper bound. However, - ;; watch out for the case where the high limit is zero! - (setf (interval-high rem) (list (interval-high rem)))) + (not (zerop (interval-high rem)))) + ;; The remainder never contains the upper bound. However, + ;; watch out for the case where the high limit is zero! + (setf (interval-high rem) (list (interval-high rem)))) rem)) (- ;; The divisor is always negative. (let ((rem (interval-neg (interval-abs div)))) (setf (interval-high rem) 0) (when (numberp (interval-low rem)) - ;; The remainder never contains the lower bound. - (setf (interval-low rem) (list (interval-low rem)))) + ;; The remainder never contains the lower bound. + (setf (interval-low rem) (list (interval-low rem)))) rem)) (otherwise ;; The divisor can be positive or negative. All bets off. The @@ -1796,9 +1796,9 @@ (let ((limit (type-bound-number (interval-high (interval-abs div))))) ;; The bound never reaches the limit, so make the interval open. (make-interval :low (if limit - (list (- limit)) - limit) - :high (list limit)))))) + (list (- limit)) + limit) + :high (list limit)))))) #| Test cases (floor-quotient-bound (make-interval :low 0.3 :high 10.3)) => #S(INTERVAL :LOW 0 :HIGH 10) @@ -1838,27 +1838,27 @@ ;; Take the ceiling of the quotient and then massage it into what we ;; need. (let ((lo (interval-low quot)) - (hi (interval-high quot))) + (hi (interval-high quot))) ;; Take the ceiling of the upper bound. The result is always a ;; closed upper bound. (setf hi (if hi - (ceiling (type-bound-number hi)) - nil)) + (ceiling (type-bound-number hi)) + nil)) ;; For the lower bound, we need to be careful. (setf lo - (cond ((consp lo) - ;; An open bound. We need to be careful here because - ;; the ceiling of '(10.0) is 11, but the ceiling of - ;; 10.0 is 10. - (multiple-value-bind (q r) (ceiling (first lo)) - (if (zerop r) - (1+ q) - q))) - (lo - ;; A closed bound, so the answer is obvious. - (ceiling lo)) - (t - lo))) + (cond ((consp lo) + ;; An open bound. We need to be careful here because + ;; the ceiling of '(10.0) is 11, but the ceiling of + ;; 10.0 is 10. + (multiple-value-bind (q r) (ceiling (first lo)) + (if (zerop r) + (1+ q) + q))) + (lo + ;; A closed bound, so the answer is obvious. + (ceiling lo)) + (t + lo))) (make-interval :low lo :high hi))) (defun ceiling-rem-bound (div) ;; The remainder depends only on the divisor. Try to get the @@ -1869,18 +1869,18 @@ (let ((rem (interval-neg (interval-abs div)))) (setf (interval-high rem) 0) (when (and (numberp (interval-low rem)) - (not (zerop (interval-low rem)))) - ;; The remainder never contains the upper bound. However, - ;; watch out for the case when the upper bound is zero! - (setf (interval-low rem) (list (interval-low rem)))) + (not (zerop (interval-low rem)))) + ;; The remainder never contains the upper bound. However, + ;; watch out for the case when the upper bound is zero! + (setf (interval-low rem) (list (interval-low rem)))) rem)) (- ;; Divisor is always negative. The remainder is positive (let ((rem (interval-abs div))) (setf (interval-low rem) 0) (when (numberp (interval-high rem)) - ;; The remainder never contains the lower bound. - (setf (interval-high rem) (list (interval-high rem)))) + ;; The remainder never contains the lower bound. + (setf (interval-high rem) (list (interval-high rem)))) rem)) (otherwise ;; The divisor can be positive or negative. All bets off. The @@ -1888,9 +1888,9 @@ (let ((limit (type-bound-number (interval-high (interval-abs div))))) ;; The bound never reaches the limit, so make the interval open. (make-interval :low (if limit - (list (- limit)) - limit) - :high (list limit)))))) + (list (- limit)) + limit) + :high (list limit)))))) #| Test cases (ceiling-quotient-bound (make-interval :low 0.3 :high 10.3)) @@ -1942,7 +1942,7 @@ ;; the result for each piece and put them back together. (destructuring-bind (neg pos) (interval-split 0 quot t t) (interval-merge-pair (ceiling-quotient-bound neg) - (floor-quotient-bound pos)))))) + (floor-quotient-bound pos)))))) (defun truncate-rem-bound (num div) ;; This is significantly more complicated than FLOOR or CEILING. We @@ -1954,27 +1954,27 @@ (+ (case (interval-range-info div) (+ - (floor-rem-bound div)) + (floor-rem-bound div)) (- - (ceiling-rem-bound div)) + (ceiling-rem-bound div)) (otherwise - (destructuring-bind (neg pos) (interval-split 0 div t t) - (interval-merge-pair (truncate-rem-bound num neg) - (truncate-rem-bound num pos)))))) + (destructuring-bind (neg pos) (interval-split 0 div t t) + (interval-merge-pair (truncate-rem-bound num neg) + (truncate-rem-bound num pos)))))) (- (case (interval-range-info div) (+ - (ceiling-rem-bound div)) + (ceiling-rem-bound div)) (- - (floor-rem-bound div)) + (floor-rem-bound div)) (otherwise - (destructuring-bind (neg pos) (interval-split 0 div t t) - (interval-merge-pair (truncate-rem-bound num neg) - (truncate-rem-bound num pos)))))) + (destructuring-bind (neg pos) (interval-split 0 div t t) + (interval-merge-pair (truncate-rem-bound num neg) + (truncate-rem-bound num pos)))))) (otherwise (destructuring-bind (neg pos) (interval-split 0 num t t) (interval-merge-pair (truncate-rem-bound neg div) - (truncate-rem-bound pos div)))))) + (truncate-rem-bound pos div)))))) ) ; PROGN ;;; Derive useful information about the range. Returns three values: @@ -1984,11 +1984,11 @@ ;;; unbounded. (defun numeric-range-info (low high) (cond ((and low (not (minusp low))) - (values '+ low high)) - ((and high (not (plusp high))) - (values '- (- high) (if low (- low) nil))) - (t - (values nil 0 (and low high (max (- low) high)))))) + (values '+ low high)) + ((and high (not (plusp high))) + (values '- (- high) (if low (- low) nil))) + (t + (values nil 0 (and low high (max (- low) high)))))) (defun integer-truncate-derive-type (number-low number-high divisor-low divisor-high) @@ -1998,59 +1998,59 @@ (multiple-value-bind (number-sign number-min number-max) (numeric-range-info number-low number-high) (multiple-value-bind (divisor-sign divisor-min divisor-max) - (numeric-range-info divisor-low divisor-high) + (numeric-range-info divisor-low divisor-high) (when (and divisor-max (zerop divisor-max)) - ;; We've got a problem: guaranteed division by zero. - (return-from integer-truncate-derive-type t)) + ;; We've got a problem: guaranteed division by zero. + (return-from integer-truncate-derive-type t)) (when (zerop divisor-min) - ;; We'll assume that they aren't going to divide by zero. - (incf divisor-min)) + ;; We'll assume that they aren't going to divide by zero. + (incf divisor-min)) (cond ((and number-sign divisor-sign) - ;; We know the sign of both. - (if (eq number-sign divisor-sign) - ;; Same sign, so the result will be positive. - `(integer ,(if divisor-max - (truncate number-min divisor-max) - 0) - ,(if number-max - (truncate number-max divisor-min) - '*)) - ;; Different signs, the result will be negative. - `(integer ,(if number-max - (- (truncate number-max divisor-min)) - '*) - ,(if divisor-max - (- (truncate number-min divisor-max)) - 0)))) - ((eq divisor-sign '+) - ;; The divisor is positive. Therefore, the number will just - ;; become closer to zero. - `(integer ,(if number-low - (truncate number-low divisor-min) - '*) - ,(if number-high - (truncate number-high divisor-min) - '*))) - ((eq divisor-sign '-) - ;; The divisor is negative. Therefore, the absolute value of - ;; the number will become closer to zero, but the sign will also - ;; change. - `(integer ,(if number-high - (- (truncate number-high divisor-min)) - '*) - ,(if number-low - (- (truncate number-low divisor-min)) - '*))) - ;; The divisor could be either positive or negative. - (number-max - ;; The number we are dividing has a bound. Divide that by the - ;; smallest posible divisor. - (let ((bound (truncate number-max divisor-min))) - `(integer ,(- bound) ,bound))) - (t - ;; The number we are dividing is unbounded, so we can't tell - ;; anything about the result. - `integer))))) + ;; We know the sign of both. + (if (eq number-sign divisor-sign) + ;; Same sign, so the result will be positive. + `(integer ,(if divisor-max + (truncate number-min divisor-max) + 0) + ,(if number-max + (truncate number-max divisor-min) + '*)) + ;; Different signs, the result will be negative. + `(integer ,(if number-max + (- (truncate number-max divisor-min)) + '*) + ,(if divisor-max + (- (truncate number-min divisor-max)) + 0)))) + ((eq divisor-sign '+) + ;; The divisor is positive. Therefore, the number will just + ;; become closer to zero. + `(integer ,(if number-low + (truncate number-low divisor-min) + '*) + ,(if number-high + (truncate number-high divisor-min) + '*))) + ((eq divisor-sign '-) + ;; The divisor is negative. Therefore, the absolute value of + ;; the number will become closer to zero, but the sign will also + ;; change. + `(integer ,(if number-high + (- (truncate number-high divisor-min)) + '*) + ,(if number-low + (- (truncate number-low divisor-min)) + '*))) + ;; The divisor could be either positive or negative. + (number-max + ;; The number we are dividing has a bound. Divide that by the + ;; smallest posible divisor. + (let ((bound (truncate number-max divisor-min))) + `(integer ,(- bound) ,bound))) + (t + ;; The number we are dividing is unbounded, so we can't tell + ;; anything about the result. + `integer))))) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun integer-rem-derive-type @@ -2060,57 +2060,57 @@ ;; smaller than the divisor. We can tell the sign of the ;; remainer if we know the sign of the number. (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high))))) - `(integer ,(if (or (null number-low) - (minusp number-low)) - (- divisor-max) - 0) - ,(if (or (null number-high) - (plusp number-high)) - divisor-max - 0))) + `(integer ,(if (or (null number-low) + (minusp number-low)) + (- divisor-max) + 0) + ,(if (or (null number-high) + (plusp number-high)) + divisor-max + 0))) ;; The divisor is potentially either very positive or very ;; negative. Therefore, the remainer is unbounded, but we might ;; be able to tell something about the sign from the number. `(integer ,(if (and number-low (not (minusp number-low))) - ;; The number we are dividing is positive. - ;; Therefore, the remainder must be positive. - 0 - '*) - ,(if (and number-high (not (plusp number-high))) - ;; The number we are dividing is negative. - ;; Therefore, the remainder must be negative. - 0 - '*)))) + ;; The number we are dividing is positive. + ;; Therefore, the remainder must be positive. + 0 + '*) + ,(if (and number-high (not (plusp number-high))) + ;; The number we are dividing is negative. + ;; Therefore, the remainder must be negative. + 0 + '*)))) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (random derive-type) ((bound &optional state)) (let ((type (lvar-type bound))) (when (numeric-type-p type) (let ((class (numeric-type-class type)) - (high (numeric-type-high type)) - (format (numeric-type-format type))) - (make-numeric-type - :class class - :format format - :low (coerce 0 (or format class 'real)) - :high (cond ((not high) nil) - ((eq class 'integer) (max (1- high) 0)) - ((or (consp high) (zerop high)) high) - (t `(,high)))))))) + (high (numeric-type-high type)) + (format (numeric-type-format type))) + (make-numeric-type + :class class + :format format + :low (coerce 0 (or format class 'real)) + :high (cond ((not high) nil) + ((eq class 'integer) (max (1- high) 0)) + ((or (consp high) (zerop high)) high) + (t `(,high)))))))) #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun random-derive-type-aux (type) (let ((class (numeric-type-class type)) - (high (numeric-type-high type)) - (format (numeric-type-format type))) + (high (numeric-type-high type)) + (format (numeric-type-format type))) (make-numeric-type - :class class - :format format - :low (coerce 0 (or format class 'real)) - :high (cond ((not high) nil) - ((eq class 'integer) (max (1- high) 0)) - ((or (consp high) (zerop high)) high) - (t `(,high)))))) + :class class + :format format + :low (coerce 0 (or format class 'real)) + :high (cond ((not high) nil) + ((eq class 'integer) (max (1- high) 0)) + ((or (consp high) (zerop high)) high) + (t `(,high)))))) #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (random derive-type) ((bound &optional state)) @@ -2125,10 +2125,10 @@ (defun integer-type-length (type) (if (numeric-type-p type) (let ((min (numeric-type-low type)) - (max (numeric-type-high type))) - (values (and min max (max (integer-length min) (integer-length max))) - (or (null max) (not (minusp max))) - (or (null min) (minusp min)))) + (max (numeric-type-high type))) + (values (and min max (max (integer-length min) (integer-length max))) + (or (null max) (not (minusp max))) + (or (null min) (minusp min)))) (values nil t t))) ;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an @@ -2182,36 +2182,36 @@ (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) (declare (ignore y-pos)) (if (not x-neg) - ;; X must be positive. - (if (not y-neg) - ;; They must both be positive. - (cond ((and (null x-len) (null y-len)) - (specifier-type 'unsigned-byte)) - ((null x-len) - (specifier-type `(unsigned-byte* ,y-len))) - ((null y-len) - (specifier-type `(unsigned-byte* ,x-len))) - (t + ;; X must be positive. + (if (not y-neg) + ;; They must both be positive. + (cond ((and (null x-len) (null y-len)) + (specifier-type 'unsigned-byte)) + ((null x-len) + (specifier-type `(unsigned-byte* ,y-len))) + ((null y-len) + (specifier-type `(unsigned-byte* ,x-len))) + (t (let ((low (logand-derive-unsigned-low-bound x y)) (high (logand-derive-unsigned-high-bound x y))) (specifier-type `(integer ,low ,high))))) - ;; X is positive, but Y might be negative. - (cond ((null x-len) - (specifier-type 'unsigned-byte)) - (t - (specifier-type `(unsigned-byte* ,x-len))))) - ;; X might be negative. - (if (not y-neg) - ;; Y must be positive. - (cond ((null y-len) - (specifier-type 'unsigned-byte)) - (t (specifier-type `(unsigned-byte* ,y-len)))) - ;; Either might be negative. - (if (and x-len y-len) - ;; The result is bounded. - (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) - ;; We can't tell squat about the result. - (specifier-type 'integer))))))) + ;; X is positive, but Y might be negative. + (cond ((null x-len) + (specifier-type 'unsigned-byte)) + (t + (specifier-type `(unsigned-byte* ,x-len))))) + ;; X might be negative. + (if (not y-neg) + ;; Y must be positive. + (cond ((null y-len) + (specifier-type 'unsigned-byte)) + (t (specifier-type `(unsigned-byte* ,y-len)))) + ;; Either might be negative. + (if (and x-len y-len) + ;; The result is bounded. + (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) + ;; We can't tell squat about the result. + (specifier-type 'integer))))))) (defun logior-derive-unsigned-low-bound (x y) (let ((a (numeric-type-low x)) @@ -2258,40 +2258,40 @@ (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) (cond ((and (not x-neg) (not y-neg)) - ;; Both are positive. + ;; Both are positive. (if (and x-len y-len) (let ((low (logior-derive-unsigned-low-bound x y)) (high (logior-derive-unsigned-high-bound x y))) (specifier-type `(integer ,low ,high))) (specifier-type `(unsigned-byte* *)))) ((not x-pos) - ;; X must be negative. - (if (not y-pos) - ;; Both are negative. The result is going to be negative - ;; and be the same length or shorter than the smaller. - (if (and x-len y-len) - ;; It's bounded. - (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1)) - ;; It's unbounded. - (specifier-type '(integer * -1))) - ;; X is negative, but we don't know about Y. The result - ;; will be negative, but no more negative than X. - (specifier-type - `(integer ,(or (numeric-type-low x) '*) - -1)))) + ;; X must be negative. + (if (not y-pos) + ;; Both are negative. The result is going to be negative + ;; and be the same length or shorter than the smaller. + (if (and x-len y-len) + ;; It's bounded. + (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1)) + ;; It's unbounded. + (specifier-type '(integer * -1))) + ;; X is negative, but we don't know about Y. The result + ;; will be negative, but no more negative than X. + (specifier-type + `(integer ,(or (numeric-type-low x) '*) + -1)))) (t - ;; X might be either positive or negative. - (if (not y-pos) - ;; But Y is negative. The result will be negative. - (specifier-type - `(integer ,(or (numeric-type-low y) '*) - -1)) - ;; We don't know squat about either. It won't get any bigger. - (if (and x-len y-len) - ;; Bounded. - (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) - ;; Unbounded. - (specifier-type 'integer)))))))) + ;; X might be either positive or negative. + (if (not y-pos) + ;; But Y is negative. The result will be negative. + (specifier-type + `(integer ,(or (numeric-type-low y) '*) + -1)) + ;; We don't know squat about either. It won't get any bigger. + (if (and x-len y-len) + ;; Bounded. + (specifier-type `(signed-byte ,(1+ (max x-len y-len)))) + ;; Unbounded. + (specifier-type 'integer)))))))) (defun logxor-derive-unsigned-low-bound (x y) (let ((a (numeric-type-low x)) @@ -2364,56 +2364,56 @@ (specifier-type 'integer)))))) (macrolet ((deffrob (logfun) - (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX"))) - `(defoptimizer (,logfun derive-type) ((x y)) - (two-arg-derive-type x y #',fun-aux #',logfun))))) + (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX"))) + `(defoptimizer (,logfun derive-type) ((x y)) + (two-arg-derive-type x y #',fun-aux #',logfun))))) (deffrob logand) (deffrob logior) (deffrob logxor)) (defoptimizer (logeqv derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (lognot-derive-type-aux - (logxor-derive-type-aux x y same-leaf))) - #'logeqv)) + (lognot-derive-type-aux + (logxor-derive-type-aux x y same-leaf))) + #'logeqv)) (defoptimizer (lognand derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (lognot-derive-type-aux - (logand-derive-type-aux x y same-leaf))) - #'lognand)) + (lognot-derive-type-aux + (logand-derive-type-aux x y same-leaf))) + #'lognand)) (defoptimizer (lognor derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (lognot-derive-type-aux - (logior-derive-type-aux x y same-leaf))) - #'lognor)) + (lognot-derive-type-aux + (logior-derive-type-aux x y same-leaf))) + #'lognor)) (defoptimizer (logandc1 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (if same-leaf - (specifier-type '(eql 0)) - (logand-derive-type-aux - (lognot-derive-type-aux x) y nil))) - #'logandc1)) + (if same-leaf + (specifier-type '(eql 0)) + (logand-derive-type-aux + (lognot-derive-type-aux x) y nil))) + #'logandc1)) (defoptimizer (logandc2 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (if same-leaf - (specifier-type '(eql 0)) - (logand-derive-type-aux - x (lognot-derive-type-aux y) nil))) - #'logandc2)) + (if same-leaf + (specifier-type '(eql 0)) + (logand-derive-type-aux + x (lognot-derive-type-aux y) nil))) + #'logandc2)) (defoptimizer (logorc1 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (if same-leaf - (specifier-type '(eql -1)) - (logior-derive-type-aux - (lognot-derive-type-aux x) y nil))) - #'logorc1)) + (if same-leaf + (specifier-type '(eql -1)) + (logior-derive-type-aux + (lognot-derive-type-aux x) y nil))) + #'logorc1)) (defoptimizer (logorc2 derive-type) ((x y)) (two-arg-derive-type x y (lambda (x y same-leaf) - (if same-leaf - (specifier-type '(eql -1)) - (logior-derive-type-aux - x (lognot-derive-type-aux y) nil))) - #'logorc2)) + (if same-leaf + (specifier-type '(eql -1)) + (logior-derive-type-aux + x (lognot-derive-type-aux y) nil))) + #'logorc2)) ;;;; miscellaneous derive-type methods @@ -2478,38 +2478,38 @@ (defun signum-derive-type-aux (type) (if (eq (numeric-type-complexp type) :complex) (let* ((format (case (numeric-type-class type) - ((integer rational) 'single-float) - (t (numeric-type-format type)))) - (bound-format (or format 'float))) - (make-numeric-type :class 'float - :format format - :complexp :complex - :low (coerce -1 bound-format) - :high (coerce 1 bound-format))) + ((integer rational) 'single-float) + (t (numeric-type-format type)))) + (bound-format (or format 'float))) + (make-numeric-type :class 'float + :format format + :complexp :complex + :low (coerce -1 bound-format) + :high (coerce 1 bound-format))) (let* ((interval (numeric-type->interval type)) - (range-info (interval-range-info interval)) - (contains-0-p (interval-contains-p 0 interval)) - (class (numeric-type-class type)) - (format (numeric-type-format type)) - (one (coerce 1 (or format class 'real))) - (zero (coerce 0 (or format class 'real))) - (minus-one (coerce -1 (or format class 'real))) - (plus (make-numeric-type :class class :format format - :low one :high one)) - (minus (make-numeric-type :class class :format format - :low minus-one :high minus-one)) - ;; KLUDGE: here we have a fairly horrible hack to deal - ;; with the schizophrenia in the type derivation engine. - ;; The problem is that the type derivers reinterpret - ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0 - ;; 0d0) within the derivation mechanism doesn't include - ;; -0d0. Ugh. So force it in here, instead. - (zero (make-numeric-type :class class :format format - :low (- zero) :high zero))) - (case range-info - (+ (if contains-0-p (type-union plus zero) plus)) - (- (if contains-0-p (type-union minus zero) minus)) - (t (type-union minus zero plus)))))) + (range-info (interval-range-info interval)) + (contains-0-p (interval-contains-p 0 interval)) + (class (numeric-type-class type)) + (format (numeric-type-format type)) + (one (coerce 1 (or format class 'real))) + (zero (coerce 0 (or format class 'real))) + (minus-one (coerce -1 (or format class 'real))) + (plus (make-numeric-type :class class :format format + :low one :high one)) + (minus (make-numeric-type :class class :format format + :low minus-one :high minus-one)) + ;; KLUDGE: here we have a fairly horrible hack to deal + ;; with the schizophrenia in the type derivation engine. + ;; The problem is that the type derivers reinterpret + ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0 + ;; 0d0) within the derivation mechanism doesn't include + ;; -0d0. Ugh. So force it in here, instead. + (zero (make-numeric-type :class class :format format + :low (- zero) :high zero))) + (case range-info + (+ (if contains-0-p (type-union plus zero) plus)) + (- (if contains-0-p (type-union minus zero) minus)) + (t (type-union minus zero plus)))))) (defoptimizer (signum derive-type) ((num)) (one-arg-derive-type num #'signum-derive-type-aux nil)) @@ -2523,28 +2523,28 @@ ;;;; size and position are constant and the operands are fixnums. (macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to - ;; expressions that evaluate to the SIZE and POSITION of - ;; the byte-specifier form SPEC. We may wrap a let around - ;; the result of the body to bind some variables. - ;; - ;; If the spec is a BYTE form, then bind the vars to the - ;; subforms. otherwise, evaluate SPEC and use the BYTE-SIZE - ;; and BYTE-POSITION. The goal of this transformation is to - ;; avoid consing up byte specifiers and then immediately - ;; throwing them away. - (with-byte-specifier ((size-var pos-var spec) &body body) - (once-only ((spec `(macroexpand ,spec)) - (temp '(gensym))) - `(if (and (consp ,spec) - (eq (car ,spec) 'byte) - (= (length ,spec) 3)) - (let ((,size-var (second ,spec)) - (,pos-var (third ,spec))) - ,@body) - (let ((,size-var `(byte-size ,,temp)) - (,pos-var `(byte-position ,,temp))) - `(let ((,,temp ,,spec)) - ,,@body)))))) + ;; expressions that evaluate to the SIZE and POSITION of + ;; the byte-specifier form SPEC. We may wrap a let around + ;; the result of the body to bind some variables. + ;; + ;; If the spec is a BYTE form, then bind the vars to the + ;; subforms. otherwise, evaluate SPEC and use the BYTE-SIZE + ;; and BYTE-POSITION. The goal of this transformation is to + ;; avoid consing up byte specifiers and then immediately + ;; throwing them away. + (with-byte-specifier ((size-var pos-var spec) &body body) + (once-only ((spec `(macroexpand ,spec)) + (temp '(gensym))) + `(if (and (consp ,spec) + (eq (car ,spec) 'byte) + (= (length ,spec) 3)) + (let ((,size-var (second ,spec)) + (,pos-var (third ,spec))) + ,@body) + (let ((,size-var `(byte-size ,,temp)) + (,pos-var `(byte-position ,,temp))) + `(let ((,,temp ,,spec)) + ,,@body)))))) (define-source-transform ldb (spec int) (with-byte-specifier (size pos spec) @@ -2565,32 +2565,32 @@ (defoptimizer (%ldb derive-type) ((size posn num)) (let ((size (lvar-type size))) (if (and (numeric-type-p size) - (csubtypep size (specifier-type 'integer))) - (let ((size-high (numeric-type-high size))) - (if (and size-high (<= size-high sb!vm:n-word-bits)) - (specifier-type `(unsigned-byte* ,size-high)) - (specifier-type 'unsigned-byte))) - *universal-type*))) + (csubtypep size (specifier-type 'integer))) + (let ((size-high (numeric-type-high size))) + (if (and size-high (<= size-high sb!vm:n-word-bits)) + (specifier-type `(unsigned-byte* ,size-high)) + (specifier-type 'unsigned-byte))) + *universal-type*))) (defoptimizer (%mask-field derive-type) ((size posn num)) (let ((size (lvar-type size)) - (posn (lvar-type posn))) + (posn (lvar-type posn))) (if (and (numeric-type-p size) - (csubtypep size (specifier-type 'integer)) - (numeric-type-p posn) - (csubtypep posn (specifier-type 'integer))) - (let ((size-high (numeric-type-high size)) - (posn-high (numeric-type-high posn))) - (if (and size-high posn-high - (<= (+ size-high posn-high) sb!vm:n-word-bits)) - (specifier-type `(unsigned-byte* ,(+ size-high posn-high))) - (specifier-type 'unsigned-byte))) - *universal-type*))) + (csubtypep size (specifier-type 'integer)) + (numeric-type-p posn) + (csubtypep posn (specifier-type 'integer))) + (let ((size-high (numeric-type-high size)) + (posn-high (numeric-type-high posn))) + (if (and size-high posn-high + (<= (+ size-high posn-high) sb!vm:n-word-bits)) + (specifier-type `(unsigned-byte* ,(+ size-high posn-high))) + (specifier-type 'unsigned-byte))) + *universal-type*))) (defun %deposit-field-derive-type-aux (size posn int) (let ((size (lvar-type size)) - (posn (lvar-type posn)) - (int (lvar-type int))) + (posn (lvar-type posn)) + (int (lvar-type int))) (when (and (numeric-type-p size) (numeric-type-p posn) (numeric-type-p int)) @@ -2599,16 +2599,16 @@ (high (numeric-type-high int)) (low (numeric-type-low int))) (when (and size-high posn-high high low - ;; KLUDGE: we need this cutoff here, otherwise we - ;; will merrily derive the type of %DPB as - ;; (UNSIGNED-BYTE 1073741822), and then attempt to - ;; canonicalize this type to (INTEGER 0 (1- (ASH 1 - ;; 1073741822))), with hilarious consequences. We - ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference - ;; over a reasonable amount of shifting, even on - ;; the alpha/32 port, where N-WORD-BITS is 32 but - ;; machine integers are 64-bits. -- CSR, - ;; 2003-09-12 + ;; KLUDGE: we need this cutoff here, otherwise we + ;; will merrily derive the type of %DPB as + ;; (UNSIGNED-BYTE 1073741822), and then attempt to + ;; canonicalize this type to (INTEGER 0 (1- (ASH 1 + ;; 1073741822))), with hilarious consequences. We + ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference + ;; over a reasonable amount of shifting, even on + ;; the alpha/32 port, where N-WORD-BITS is 32 but + ;; machine integers are 64-bits. -- CSR, + ;; 2003-09-12 (<= (+ size-high posn-high) (* 4 sb!vm:n-word-bits))) (let ((raw-bit-count (max (integer-length high) (integer-length low) @@ -2625,21 +2625,21 @@ (%deposit-field-derive-type-aux size posn int)) (deftransform %ldb ((size posn int) - (fixnum fixnum integer) - (unsigned-byte #.sb!vm:n-word-bits)) + (fixnum fixnum integer) + (unsigned-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(logand (ash int (- posn)) - (ash ,(1- (ash 1 sb!vm:n-word-bits)) - (- size ,sb!vm:n-word-bits)))) + (ash ,(1- (ash 1 sb!vm:n-word-bits)) + (- size ,sb!vm:n-word-bits)))) (deftransform %mask-field ((size posn int) - (fixnum fixnum integer) - (unsigned-byte #.sb!vm:n-word-bits)) + (fixnum fixnum integer) + (unsigned-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(logand int - (ash (ash ,(1- (ash 1 sb!vm:n-word-bits)) - (- size ,sb!vm:n-word-bits)) - posn))) + (ash (ash ,(1- (ash 1 sb!vm:n-word-bits)) + (- size ,sb!vm:n-word-bits)) + posn))) ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use ;;; (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N)) @@ -2648,45 +2648,45 @@ ;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N). (deftransform %dpb ((new size posn int) - * - (unsigned-byte #.sb!vm:n-word-bits)) + * + (unsigned-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(let ((mask (ldb (byte size 0) -1))) (logior (ash (logand new mask) posn) - (logand int (lognot (ash mask posn)))))) + (logand int (lognot (ash mask posn)))))) (deftransform %dpb ((new size posn int) - * - (signed-byte #.sb!vm:n-word-bits)) + * + (signed-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(let ((mask (ldb (byte size 0) -1))) (logior (ash (logand new mask) posn) - (logand int (lognot (ash mask posn)))))) + (logand int (lognot (ash mask posn)))))) (deftransform %deposit-field ((new size posn int) - * - (unsigned-byte #.sb!vm:n-word-bits)) + * + (unsigned-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand new mask) - (logand int (lognot mask))))) + (logand int (lognot mask))))) (deftransform %deposit-field ((new size posn int) - * - (signed-byte #.sb!vm:n-word-bits)) + * + (signed-byte #.sb!vm:n-word-bits)) "convert to inline logical operations" `(let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand new mask) - (logand int (lognot mask))))) + (logand int (lognot mask))))) (defoptimizer (mask-signed-field derive-type) ((size x)) (let ((size (lvar-type size))) (if (numeric-type-p size) - (let ((size-high (numeric-type-high size))) - (if (and size-high (<= 1 size-high sb!vm:n-word-bits)) - (specifier-type `(signed-byte ,size-high)) - *universal-type*)) - *universal-type*))) + (let ((size-high (numeric-type-high size))) + (if (and size-high (<= 1 size-high sb!vm:n-word-bits)) + (specifier-type `(signed-byte ,size-high)) + *universal-type*)) + *universal-type*))) ;;; Modular functions @@ -2825,15 +2825,15 @@ ;;; If a constant appears as the first arg, swap the args. (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node) (if (and (constant-lvar-p x) - (not (constant-lvar-p y))) + (not (constant-lvar-p y))) `(,(lvar-fun-name (basic-combination-fun node)) - y - ,(lvar-value x)) + y + ,(lvar-value x)) (give-up-ir1-transform))) (dolist (x '(= char= + * logior logand logxor)) (%deftransform x '(function * *) #'commutative-arg-swap - "place constant arg last")) + "place constant arg last")) ;;; Handle the case of a constant BOOLE-CODE. (deftransform boole ((op x y) * *) @@ -2860,7 +2860,7 @@ (#.sb!xc:boole-orc2 '(logorc2 x y)) (t (abort-ir1-transform "~S is an illegal control arg to BOOLE." - control))))) + control))))) ;;;; converting special case multiply/divide to shifts @@ -2870,34 +2870,34 @@ (unless (constant-lvar-p y) (give-up-ir1-transform)) (let* ((y (lvar-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) + (y-abs (abs y)) + (len (1- (integer-length y-abs)))) (unless (and (> y-abs 0) (= y-abs (ash 1 len))) (give-up-ir1-transform)) (if (minusp y) - `(- (ash x ,len)) - `(ash x ,len)))) + `(- (ash x ,len)) + `(ash x ,len)))) ;;; If arg is a constant power of two, turn FLOOR into a shift and ;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a ;;; remainder. (flet ((frob (y ceil-p) - (unless (constant-lvar-p y) - (give-up-ir1-transform)) - (let* ((y (lvar-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) - (unless (and (> y-abs 0) (= y-abs (ash 1 len))) - (give-up-ir1-transform)) - (let ((shift (- len)) - (mask (1- y-abs)) + (unless (constant-lvar-p y) + (give-up-ir1-transform)) + (let* ((y (lvar-value y)) + (y-abs (abs y)) + (len (1- (integer-length y-abs)))) + (unless (and (> y-abs 0) (= y-abs (ash 1 len))) + (give-up-ir1-transform)) + (let ((shift (- len)) + (mask (1- y-abs)) (delta (if ceil-p (* (signum y) (1- y-abs)) 0))) - `(let ((x (+ x ,delta))) - ,(if (minusp y) - `(values (ash (- x) ,shift) - (- (- (logand (- x) ,mask)) ,delta)) - `(values (ash x ,shift) - (- (logand x ,mask) ,delta)))))))) + `(let ((x (+ x ,delta))) + ,(if (minusp y) + `(values (ash (- x) ,shift) + (- (- (logand (- x) ,mask)) ,delta)) + `(values (ash x ,shift) + (- (logand x ,mask) ,delta)))))))) (deftransform floor ((x y) (integer integer) *) "convert division by 2^k to shift" (frob y nil)) @@ -2911,14 +2911,14 @@ (unless (constant-lvar-p y) (give-up-ir1-transform)) (let* ((y (lvar-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) + (y-abs (abs y)) + (len (1- (integer-length y-abs)))) (unless (and (> y-abs 0) (= y-abs (ash 1 len))) (give-up-ir1-transform)) (let ((mask (1- y-abs))) (if (minusp y) - `(- (logand (- x) ,mask)) - `(logand x ,mask))))) + `(- (logand (- x) ,mask)) + `(logand x ,mask))))) ;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask. (deftransform truncate ((x y) (integer integer)) @@ -2926,21 +2926,21 @@ (unless (constant-lvar-p y) (give-up-ir1-transform)) (let* ((y (lvar-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) + (y-abs (abs y)) + (len (1- (integer-length y-abs)))) (unless (and (> y-abs 0) (= y-abs (ash 1 len))) (give-up-ir1-transform)) (let* ((shift (- len)) - (mask (1- y-abs))) + (mask (1- y-abs))) `(if (minusp x) - (values ,(if (minusp y) - `(ash (- x) ,shift) - `(- (ash (- x) ,shift))) - (- (logand (- x) ,mask))) - (values ,(if (minusp y) - `(ash (- ,mask x) ,shift) - `(ash x ,shift)) - (logand x ,mask)))))) + (values ,(if (minusp y) + `(ash (- x) ,shift) + `(- (ash (- x) ,shift))) + (- (logand (- x) ,mask))) + (values ,(if (minusp y) + `(ash (- ,mask x) ,shift) + `(ash x ,shift)) + (logand x ,mask)))))) ;;; And the same for REM. (deftransform rem ((x y) (integer integer) *) @@ -2948,14 +2948,14 @@ (unless (constant-lvar-p y) (give-up-ir1-transform)) (let* ((y (lvar-value y)) - (y-abs (abs y)) - (len (1- (integer-length y-abs)))) + (y-abs (abs y)) + (len (1- (integer-length y-abs)))) (unless (and (> y-abs 0) (= y-abs (ash 1 len))) (give-up-ir1-transform)) (let ((mask (1- y-abs))) `(if (minusp x) - (- (logand (- x) ,mask)) - (logand x ,mask))))) + (- (logand (- x) ,mask)) + (logand x ,mask))))) ;;;; arithmetic and logical identity operation elimination @@ -3007,9 +3007,9 @@ (defun not-more-contagious (x y) (declare (type continuation x y)) (let ((x (lvar-type x)) - (y (lvar-type y))) + (y (lvar-type y))) (values (type= (numeric-contagion x y) - (numeric-contagion y y))))) + (numeric-contagion y y))))) ;;; Patched version by Raymond Toy. dtc: Should be safer although it ;;; XXX needs more work as valid transforms are missed; some cases are ;;; specific to particular transform functions so the use of this @@ -3017,22 +3017,22 @@ (defun not-more-contagious (x y) (declare (type lvar x y)) (flet ((simple-numeric-type (num) - (and (numeric-type-p num) - ;; Return non-NIL if NUM is integer, rational, or a float - ;; of some type (but not FLOAT) - (case (numeric-type-class num) - ((integer rational) - t) - (float - (numeric-type-format num)) - (t - nil))))) + (and (numeric-type-p num) + ;; Return non-NIL if NUM is integer, rational, or a float + ;; of some type (but not FLOAT) + (case (numeric-type-class num) + ((integer rational) + t) + (float + (numeric-type-format num)) + (t + nil))))) (let ((x (lvar-type x)) - (y (lvar-type y))) + (y (lvar-type y))) (if (and (simple-numeric-type x) - (simple-numeric-type y)) - (values (type= (numeric-contagion x y) - (numeric-contagion y y))))))) + (simple-numeric-type y)) + (values (type= (numeric-contagion x y) + (numeric-contagion y y))))))) ;;; Fold (+ x 0). ;;; @@ -3042,8 +3042,8 @@ "fold zero arg" (let ((val (lvar-value y))) (unless (and (zerop val) - (not (and (floatp val) (plusp (float-sign val)))) - (not-more-contagious y x)) + (not (and (floatp val) (plusp (float-sign val)))) + (not-more-contagious y x)) (give-up-ir1-transform))) 'x) @@ -3055,8 +3055,8 @@ "fold zero arg" (let ((val (lvar-value y))) (unless (and (zerop val) - (not (and (floatp val) (minusp (float-sign val)))) - (not-more-contagious y x)) + (not (and (floatp val) (minusp (float-sign val)))) + (not-more-contagious y x)) (give-up-ir1-transform))) 'x) @@ -3097,13 +3097,13 @@ ;; both parts are float `(1+ (* x ,val))) (t (give-up-ir1-transform))))) - ((= val 2) '(* x x)) - ((= val -2) '(/ (* x x))) - ((= val 3) '(* x x x)) - ((= val -3) '(/ (* x x x))) - ((= val 1/2) '(sqrt x)) - ((= val -1/2) '(/ (sqrt x))) - (t (give-up-ir1-transform))))) + ((= val 2) '(* x x)) + ((= val -2) '(/ (* x x))) + ((= val 3) '(* x x x)) + ((= val -3) '(/ (* x x x))) + ((= val 1/2) '(sqrt x)) + ((= val -1/2) '(/ (sqrt x))) + (t (give-up-ir1-transform))))) ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these ;;; transformations? @@ -3132,11 +3132,11 @@ (deftransform char-equal ((a b) (base-char base-char)) "open code" '(let* ((ac (char-code a)) - (bc (char-code b)) - (sum (logxor ac bc))) + (bc (char-code b)) + (sum (logxor ac bc))) (or (zerop sum) - (when (eql sum #x20) - (let ((sum (+ ac bc))) + (when (eql sum #x20) + (let ((sum (+ ac bc))) (or (and (> sum 161) (< sum 213)) (and (> sum 415) (< sum 461)) (and (> sum 463) (< sum 477)))))))) @@ -3144,26 +3144,26 @@ (deftransform char-upcase ((x) (base-char)) "open code" '(let ((n-code (char-code x))) - (if (or (and (> n-code #o140) ; Octal 141 is #\a. - (< n-code #o173)) ; Octal 172 is #\z. + (if (or (and (> n-code #o140) ; Octal 141 is #\a. + (< n-code #o173)) ; Octal 172 is #\z. (and (> n-code #o337) (< n-code #o367)) (and (> n-code #o367) (< n-code #o377))) - (code-char (logxor #x20 n-code)) - x))) + (code-char (logxor #x20 n-code)) + x))) (deftransform char-downcase ((x) (base-char)) "open code" '(let ((n-code (char-code x))) - (if (or (and (> n-code 64) ; 65 is #\A. + (if (or (and (> n-code 64) ; 65 is #\A. (< n-code 91)) ; 90 is #\Z. (and (> n-code 191) (< n-code 215)) (and (> n-code 215) (< n-code 223))) - (code-char (logxor #x20 n-code)) - x))) + (code-char (logxor #x20 n-code)) + x))) ;;;; equality predicate transforms @@ -3173,21 +3173,21 @@ (defun same-leaf-ref-p (x y) (declare (type lvar x y)) (let ((x-use (principal-lvar-use x)) - (y-use (principal-lvar-use y))) + (y-use (principal-lvar-use y))) (and (ref-p x-use) - (ref-p y-use) - (eq (ref-leaf x-use) (ref-leaf y-use)) - (constant-reference-p x-use)))) + (ref-p y-use) + (eq (ref-leaf x-use) (ref-leaf y-use)) + (constant-reference-p x-use)))) ;;; If X and Y are the same leaf, then the result is true. Otherwise, ;;; if there is no intersection between the types of the arguments, ;;; then the result is definitely false. (deftransform simple-equality-transform ((x y) * * - :defun-only t) + :defun-only t) (cond ((same-leaf-ref-p x y) t) ((not (types-equal-or-intersect (lvar-type x) (lvar-type y))) - nil) + nil) (t (give-up-ir1-transform)))) (macrolet ((def (x) @@ -3211,8 +3211,8 @@ (deftransform eql ((x y) * *) "convert to simpler equality predicate" (let ((x-type (lvar-type x)) - (y-type (lvar-type y)) - (char-type (specifier-type 'character))) + (y-type (lvar-type y)) + (char-type (specifier-type 'character))) (flet ((simple-type-p (type) (csubtypep type (specifier-type '(or fixnum (not number))))) (fixnum-type-p (type) @@ -3223,18 +3223,18 @@ nil) ((and (csubtypep x-type char-type) (csubtypep y-type char-type)) - '(char= x y)) + '(char= x y)) ((or (fixnum-type-p x-type) (fixnum-type-p y-type)) (give-up-ir1-transform)) ((or (simple-type-p x-type) (simple-type-p y-type)) '(eq x y)) - ((and (not (constant-lvar-p y)) - (or (constant-lvar-p x) - (and (csubtypep x-type y-type) - (not (csubtypep y-type x-type))))) - '(eql y x)) - (t - (give-up-ir1-transform)))))) + ((and (not (constant-lvar-p y)) + (or (constant-lvar-p x) + (and (csubtypep x-type y-type) + (not (csubtypep y-type x-type))))) + '(eql y x)) + (t + (give-up-ir1-transform)))))) ;;; similarly to the EQL transform above, we attempt to constant-fold ;;; or convert to a simpler predicate: mostly we have to be careful @@ -3242,24 +3242,24 @@ (deftransform equal ((x y) * *) "convert to simpler equality predicate" (let ((x-type (lvar-type x)) - (y-type (lvar-type y)) - (string-type (specifier-type 'string)) - (bit-vector-type (specifier-type 'bit-vector))) + (y-type (lvar-type y)) + (string-type (specifier-type 'string)) + (bit-vector-type (specifier-type 'bit-vector))) (cond ((same-leaf-ref-p x y) t) ((and (csubtypep x-type string-type) - (csubtypep y-type string-type)) + (csubtypep y-type string-type)) '(string= x y)) ((and (csubtypep x-type bit-vector-type) - (csubtypep y-type bit-vector-type)) + (csubtypep y-type bit-vector-type)) '(bit-vector-= x y)) ;; if at least one is not a string, and at least one is not a ;; bit-vector, then we can reason from types. ((and (not (and (types-equal-or-intersect x-type string-type) - (types-equal-or-intersect y-type string-type))) - (not (and (types-equal-or-intersect x-type bit-vector-type) - (types-equal-or-intersect y-type bit-vector-type))) - (not (types-equal-or-intersect x-type y-type))) + (types-equal-or-intersect y-type string-type))) + (not (and (types-equal-or-intersect x-type bit-vector-type) + (types-equal-or-intersect y-type bit-vector-type))) + (not (types-equal-or-intersect x-type y-type))) nil) (t (give-up-ir1-transform))))) @@ -3268,30 +3268,30 @@ (deftransform = ((x y) * *) "open code" (let ((x-type (lvar-type x)) - (y-type (lvar-type y))) + (y-type (lvar-type y))) (if (and (csubtypep x-type (specifier-type 'number)) - (csubtypep y-type (specifier-type 'number))) - (cond ((or (and (csubtypep x-type (specifier-type 'float)) - (csubtypep y-type (specifier-type 'float))) - (and (csubtypep x-type (specifier-type '(complex float))) - (csubtypep y-type (specifier-type '(complex float))))) - ;; They are both floats. Leave as = so that -0.0 is - ;; handled correctly. - (give-up-ir1-transform)) - ((or (and (csubtypep x-type (specifier-type 'rational)) - (csubtypep y-type (specifier-type 'rational))) - (and (csubtypep x-type - (specifier-type '(complex rational))) - (csubtypep y-type - (specifier-type '(complex rational))))) - ;; They are both rationals and complexp is the same. - ;; Convert to EQL. - '(eql x y)) - (t - (give-up-ir1-transform - "The operands might not be the same type."))) - (give-up-ir1-transform - "The operands might not be the same type.")))) + (csubtypep y-type (specifier-type 'number))) + (cond ((or (and (csubtypep x-type (specifier-type 'float)) + (csubtypep y-type (specifier-type 'float))) + (and (csubtypep x-type (specifier-type '(complex float))) + (csubtypep y-type (specifier-type '(complex float))))) + ;; They are both floats. Leave as = so that -0.0 is + ;; handled correctly. + (give-up-ir1-transform)) + ((or (and (csubtypep x-type (specifier-type 'rational)) + (csubtypep y-type (specifier-type 'rational))) + (and (csubtypep x-type + (specifier-type '(complex rational))) + (csubtypep y-type + (specifier-type '(complex rational))))) + ;; They are both rationals and complexp is the same. + ;; Convert to EQL. + '(eql x y)) + (t + (give-up-ir1-transform + "The operands might not be the same type."))) + (give-up-ir1-transform + "The operands might not be the same type.")))) ;;; If LVAR's type is a numeric type, then return the type, otherwise ;;; GIVE-UP-IR1-TRANSFORM. @@ -3335,7 +3335,7 @@ ;; we could do some compile-time computation as in transforms for ;; < above. -- CSR, 2003-07-01 ((and (constant-lvar-p first) - (not (constant-lvar-p second))) + (not (constant-lvar-p second))) `(,inverse y x)) (t (give-up-ir1-transform)))) @@ -3364,23 +3364,23 @@ (defun multi-compare (predicate args not-p type) (let ((nargs (length args))) (cond ((< nargs 1) (values nil t)) - ((= nargs 1) `(progn (the ,type ,@args) t)) - ((= nargs 2) - (if not-p - `(if (,predicate ,(first args) ,(second args)) nil t) - (values nil t))) - (t - (do* ((i (1- nargs) (1- i)) - (last nil current) - (current (gensym) (gensym)) - (vars (list current) (cons current vars)) - (result t (if not-p - `(if (,predicate ,current ,last) - nil ,result) - `(if (,predicate ,current ,last) - ,result nil)))) - ((zerop i) - `((lambda ,vars (declare (type ,type ,@vars)) ,result) + ((= nargs 1) `(progn (the ,type ,@args) t)) + ((= nargs 2) + (if not-p + `(if (,predicate ,(first args) ,(second args)) nil t) + (values nil t))) + (t + (do* ((i (1- nargs) (1- i)) + (last nil current) + (current (gensym) (gensym)) + (vars (list current) (cons current vars)) + (result t (if not-p + `(if (,predicate ,current ,last) + nil ,result) + `(if (,predicate ,current ,last) + ,result nil)))) + ((zerop i) + `((lambda ,vars (declare (type ,type ,@vars)) ,result) ,@args))))))) (define-source-transform = (&rest args) (multi-compare '= args nil 'number)) @@ -3419,24 +3419,24 @@ (defun multi-not-equal (predicate args type) (let ((nargs (length args))) (cond ((< nargs 1) (values nil t)) - ((= nargs 1) `(progn (the ,type ,@args) t)) - ((= nargs 2) - `(if (,predicate ,(first args) ,(second args)) nil t)) - ((not (policy *lexenv* - (and (>= speed space) - (>= speed compilation-speed)))) - (values nil t)) - (t - (let ((vars (make-gensym-list nargs))) - (do ((var vars next) - (next (cdr vars) (cdr next)) - (result t)) - ((null next) - `((lambda ,vars (declare (type ,type ,@vars)) ,result) + ((= nargs 1) `(progn (the ,type ,@args) t)) + ((= nargs 2) + `(if (,predicate ,(first args) ,(second args)) nil t)) + ((not (policy *lexenv* + (and (>= speed space) + (>= speed compilation-speed)))) + (values nil t)) + (t + (let ((vars (make-gensym-list nargs))) + (do ((var vars next) + (next (cdr vars) (cdr next)) + (result t)) + ((null next) + `((lambda ,vars (declare (type ,type ,@vars)) ,result) ,@args)) - (let ((v1 (first var))) - (dolist (v2 next) - (setq result `(if (,predicate ,v1 ,v2) nil ,result)))))))))) + (let ((v1 (first var))) + (dolist (v2 next) + (setq result `(if (,predicate ,v1 ,v2) nil ,result)))))))))) (define-source-transform /= (&rest args) (multi-not-equal '= args 'number)) @@ -3449,15 +3449,15 @@ (define-source-transform max (arg0 &rest rest) (once-only ((arg0 arg0)) (if (null rest) - `(values (the real ,arg0)) - `(let ((maxrest (max ,@rest))) - (if (>= ,arg0 maxrest) ,arg0 maxrest))))) + `(values (the real ,arg0)) + `(let ((maxrest (max ,@rest))) + (if (>= ,arg0 maxrest) ,arg0 maxrest))))) (define-source-transform min (arg0 &rest rest) (once-only ((arg0 arg0)) (if (null rest) - `(values (the real ,arg0)) - `(let ((minrest (min ,@rest))) - (if (<= ,arg0 minrest) ,arg0 minrest))))) + `(values (the real ,arg0)) + `(let ((minrest (min ,@rest))) + (if (<= ,arg0 minrest) ,arg0 minrest))))) ;;;; converting N-arg arithmetic functions ;;;; @@ -3468,23 +3468,23 @@ (declaim (ftype (function (symbol t list) list) associate-args)) (defun associate-args (function first-arg more-args) (let ((next (rest more-args)) - (arg (first more-args))) + (arg (first more-args))) (if (null next) - `(,function ,first-arg ,arg) - (associate-args function `(,function ,first-arg ,arg) next)))) + `(,function ,first-arg ,arg) + (associate-args function `(,function ,first-arg ,arg) next)))) ;;; Do source transformations for transitive functions such as +. ;;; One-arg cases are replaced with the arg and zero arg cases with ;;; the identity. ONE-ARG-RESULT-TYPE is, if non-NIL, the type to ;;; ensure (with THE) that the argument in one-argument calls is. (defun source-transform-transitive (fun args identity - &optional one-arg-result-type) + &optional one-arg-result-type) (declare (symbol fun) (list args)) (case (length args) (0 identity) (1 (if one-arg-result-type - `(values (the ,one-arg-result-type ,(first args))) - `(values ,(first args)))) + `(values (the ,one-arg-result-type ,(first args))) + `(values ,(first args)))) (2 (values nil t)) (t (associate-args fun (first args) (rest args))))) @@ -3546,8 +3546,8 @@ (let ((args (cons arg more-args))) `(multiple-value-call ,fun ,@(mapcar (lambda (x) - `(values ,x)) - (butlast args)) + `(values ,x)) + (butlast args)) (values-list ,(car (last args)))))) ;;;; transforming FORMAT @@ -3570,30 +3570,30 @@ (setq string (coerce string 'simple-string))) (multiple-value-bind (min max) (handler-case (sb!format:%compiler-walk-format-string string args) - (sb!format:format-error (c) - (compiler-warn "~A" c))) + (sb!format:format-error (c) + (compiler-warn "~A" c))) (when min (let ((nargs (length args))) - (cond - ((< nargs min) - (warn 'format-too-few-args-warning - :format-control - "Too few arguments (~D) to ~S ~S: requires at least ~D." - :format-arguments (list nargs fun string min))) - ((> nargs max) - (warn 'format-too-many-args-warning - :format-control - "Too many arguments (~D) to ~S ~S: uses at most ~D." - :format-arguments (list nargs fun string max)))))))) + (cond + ((< nargs min) + (warn 'format-too-few-args-warning + :format-control + "Too few arguments (~D) to ~S ~S: requires at least ~D." + :format-arguments (list nargs fun string min))) + ((> nargs max) + (warn 'format-too-many-args-warning + :format-control + "Too many arguments (~D) to ~S ~S: uses at most ~D." + :format-arguments (list nargs fun string max)))))))) (defoptimizer (format optimizer) ((dest control &rest args)) (when (constant-lvar-p control) (let ((x (lvar-value control))) (when (stringp x) - (check-format-args x args 'format))))) + (check-format-args x args 'format))))) (deftransform format ((dest control &rest args) (t simple-string &rest t) * - :policy (> speed space)) + :policy (> speed space)) (unless (constant-lvar-p control) (give-up-ir1-transform "The control string is not a constant.")) (let ((arg-names (make-gensym-list (length args)))) @@ -3602,14 +3602,14 @@ (format dest (formatter ,(lvar-value control)) ,@arg-names)))) (deftransform format ((stream control &rest args) (stream function &rest t) * - :policy (> speed space)) + :policy (> speed space)) (let ((arg-names (make-gensym-list (length args)))) `(lambda (stream control ,@arg-names) (funcall control stream ,@arg-names) nil))) (deftransform format ((tee control &rest args) ((member t) function &rest t) * - :policy (> speed space)) + :policy (> speed space)) (let ((arg-names (make-gensym-list (length args)))) `(lambda (tee control ,@arg-names) (declare (ignore tee)) @@ -3618,11 +3618,11 @@ (macrolet ((def (name) - `(defoptimizer (,name optimizer) ((control &rest args)) - (when (constant-lvar-p control) - (let ((x (lvar-value control))) - (when (stringp x) - (check-format-args x args ',name))))))) + `(defoptimizer (,name optimizer) ((control &rest args)) + (when (constant-lvar-p control) + (let ((x (lvar-value control))) + (when (stringp x) + (check-format-args x args ',name))))))) (def error) (def warn) #+sb-xc-host ; Only we should be using these @@ -3638,38 +3638,38 @@ (defoptimizer (cerror optimizer) ((report control &rest args)) (when (and (constant-lvar-p control) - (constant-lvar-p report)) + (constant-lvar-p report)) (let ((x (lvar-value control)) - (y (lvar-value report))) + (y (lvar-value report))) (when (and (stringp x) (stringp y)) - (multiple-value-bind (min1 max1) - (handler-case - (sb!format:%compiler-walk-format-string x args) - (sb!format:format-error (c) - (compiler-warn "~A" c))) - (when min1 - (multiple-value-bind (min2 max2) - (handler-case - (sb!format:%compiler-walk-format-string y args) - (sb!format:format-error (c) - (compiler-warn "~A" c))) - (when min2 - (let ((nargs (length args))) - (cond - ((< nargs (min min1 min2)) - (warn 'format-too-few-args-warning - :format-control - "Too few arguments (~D) to ~S ~S ~S: ~ + (multiple-value-bind (min1 max1) + (handler-case + (sb!format:%compiler-walk-format-string x args) + (sb!format:format-error (c) + (compiler-warn "~A" c))) + (when min1 + (multiple-value-bind (min2 max2) + (handler-case + (sb!format:%compiler-walk-format-string y args) + (sb!format:format-error (c) + (compiler-warn "~A" c))) + (when min2 + (let ((nargs (length args))) + (cond + ((< nargs (min min1 min2)) + (warn 'format-too-few-args-warning + :format-control + "Too few arguments (~D) to ~S ~S ~S: ~ requires at least ~D." - :format-arguments - (list nargs 'cerror y x (min min1 min2)))) - ((> nargs (max max1 max2)) - (warn 'format-too-many-args-warning - :format-control - "Too many arguments (~D) to ~S ~S ~S: ~ + :format-arguments + (list nargs 'cerror y x (min min1 min2)))) + ((> nargs (max max1 max2)) + (warn 'format-too-many-args-warning + :format-control + "Too many arguments (~D) to ~S ~S ~S: ~ uses at most ~D." - :format-arguments - (list nargs 'cerror y x (max max1 max2)))))))))))))) + :format-arguments + (list nargs 'cerror y x (max max1 max2)))))))))))))) (defoptimizer (coerce derive-type) ((value type)) (cond @@ -3679,44 +3679,44 @@ ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of ;; type COMPLEX. (let* ((specifier (lvar-value type)) - (result-typeoid (careful-specifier-type specifier))) + (result-typeoid (careful-specifier-type specifier))) (cond - ((null result-typeoid) nil) - ((csubtypep result-typeoid (specifier-type 'number)) - ;; the difficult case: we have to cope with ANSI 12.1.5.3 - ;; Rule of Canonical Representation for Complex Rationals, - ;; which is a truly nasty delivery to field. - (cond - ((csubtypep result-typeoid (specifier-type 'real)) - ;; cleverness required here: it would be nice to deduce - ;; that something of type (INTEGER 2 3) coerced to type - ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0). - ;; FLOAT gets its own clause because it's implemented as - ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE - ;; logic below. - result-typeoid) - ((and (numeric-type-p result-typeoid) - (eq (numeric-type-complexp result-typeoid) :real)) - ;; FIXME: is this clause (a) necessary or (b) useful? - result-typeoid) - ((or (csubtypep result-typeoid - (specifier-type '(complex single-float))) - (csubtypep result-typeoid - (specifier-type '(complex double-float))) - #!+long-float - (csubtypep result-typeoid - (specifier-type '(complex long-float)))) - ;; float complex types are never canonicalized. - result-typeoid) - (t - ;; if it's not a REAL, or a COMPLEX FLOAToid, it's - ;; probably just a COMPLEX or equivalent. So, in that - ;; case, we will return a complex or an object of the - ;; provided type if it's rational: - (type-union result-typeoid - (type-intersection (lvar-type value) - (specifier-type 'rational)))))) - (t result-typeoid)))) + ((null result-typeoid) nil) + ((csubtypep result-typeoid (specifier-type 'number)) + ;; the difficult case: we have to cope with ANSI 12.1.5.3 + ;; Rule of Canonical Representation for Complex Rationals, + ;; which is a truly nasty delivery to field. + (cond + ((csubtypep result-typeoid (specifier-type 'real)) + ;; cleverness required here: it would be nice to deduce + ;; that something of type (INTEGER 2 3) coerced to type + ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0). + ;; FLOAT gets its own clause because it's implemented as + ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE + ;; logic below. + result-typeoid) + ((and (numeric-type-p result-typeoid) + (eq (numeric-type-complexp result-typeoid) :real)) + ;; FIXME: is this clause (a) necessary or (b) useful? + result-typeoid) + ((or (csubtypep result-typeoid + (specifier-type '(complex single-float))) + (csubtypep result-typeoid + (specifier-type '(complex double-float))) + #!+long-float + (csubtypep result-typeoid + (specifier-type '(complex long-float)))) + ;; float complex types are never canonicalized. + result-typeoid) + (t + ;; if it's not a REAL, or a COMPLEX FLOAToid, it's + ;; probably just a COMPLEX or equivalent. So, in that + ;; case, we will return a complex or an object of the + ;; provided type if it's rational: + (type-union result-typeoid + (type-intersection (lvar-type value) + (specifier-type 'rational)))))) + (t result-typeoid)))) (t ;; OK, the result-type argument isn't constant. However, there ;; are common uses where we can still do better than just @@ -3728,98 +3728,98 @@ ;; time-critical and get to this branch of the COND (non-constant ;; second argument to COERCE). -- CSR, 2002-12-16 (let ((value-type (lvar-type value)) - (type-type (lvar-type type))) + (type-type (lvar-type type))) (labels - ((good-cons-type-p (cons-type) - ;; Make sure the cons-type we're looking at is something - ;; we're prepared to handle which is basically something - ;; that array-element-type can return. - (or (and (member-type-p cons-type) - (null (rest (member-type-members cons-type))) - (null (first (member-type-members cons-type)))) - (let ((car-type (cons-type-car-type cons-type))) - (and (member-type-p car-type) - (null (rest (member-type-members car-type))) - (or (symbolp (first (member-type-members car-type))) - (numberp (first (member-type-members car-type))) - (and (listp (first (member-type-members - car-type))) - (numberp (first (first (member-type-members - car-type)))))) - (good-cons-type-p (cons-type-cdr-type cons-type)))))) - (unconsify-type (good-cons-type) - ;; Convert the "printed" respresentation of a cons - ;; specifier into a type specifier. That is, the - ;; specifier (CONS (EQL SIGNED-BYTE) (CONS (EQL 16) - ;; NULL)) is converted to (SIGNED-BYTE 16). - (cond ((or (null good-cons-type) - (eq good-cons-type 'null)) - nil) - ((and (eq (first good-cons-type) 'cons) - (eq (first (second good-cons-type)) 'member)) - `(,(second (second good-cons-type)) - ,@(unconsify-type (caddr good-cons-type)))))) - (coerceable-p (c-type) - ;; Can the value be coerced to the given type? Coerce is - ;; complicated, so we don't handle every possible case - ;; here---just the most common and easiest cases: - ;; - ;; * Any REAL can be coerced to a FLOAT type. - ;; * Any NUMBER can be coerced to a (COMPLEX - ;; SINGLE/DOUBLE-FLOAT). - ;; - ;; FIXME I: we should also be able to deal with characters - ;; here. - ;; - ;; FIXME II: I'm not sure that anything is necessary - ;; here, at least while COMPLEX is not a specialized - ;; array element type in the system. Reasoning: if - ;; something cannot be coerced to the requested type, an - ;; error will be raised (and so any downstream compiled - ;; code on the assumption of the returned type is - ;; unreachable). If something can, then it will be of - ;; the requested type, because (by assumption) COMPLEX - ;; (and other difficult types like (COMPLEX INTEGER) - ;; aren't specialized types. - (let ((coerced-type c-type)) - (or (and (subtypep coerced-type 'float) - (csubtypep value-type (specifier-type 'real))) - (and (subtypep coerced-type - '(or (complex single-float) - (complex double-float))) - (csubtypep value-type (specifier-type 'number)))))) - (process-types (type) - ;; FIXME: This needs some work because we should be able - ;; to derive the resulting type better than just the - ;; type arg of coerce. That is, if X is (INTEGER 10 - ;; 20), then (COERCE X 'DOUBLE-FLOAT) should say - ;; (DOUBLE-FLOAT 10d0 20d0) instead of just - ;; double-float. - (cond ((member-type-p type) - (let ((members (member-type-members type))) - (if (every #'coerceable-p members) - (specifier-type `(or ,@members)) - *universal-type*))) - ((and (cons-type-p type) - (good-cons-type-p type)) - (let ((c-type (unconsify-type (type-specifier type)))) - (if (coerceable-p c-type) - (specifier-type c-type) - *universal-type*))) - (t - *universal-type*)))) - (cond ((union-type-p type-type) - (apply #'type-union (mapcar #'process-types - (union-type-types type-type)))) - ((or (member-type-p type-type) - (cons-type-p type-type)) - (process-types type-type)) - (t - *universal-type*))))))) + ((good-cons-type-p (cons-type) + ;; Make sure the cons-type we're looking at is something + ;; we're prepared to handle which is basically something + ;; that array-element-type can return. + (or (and (member-type-p cons-type) + (null (rest (member-type-members cons-type))) + (null (first (member-type-members cons-type)))) + (let ((car-type (cons-type-car-type cons-type))) + (and (member-type-p car-type) + (null (rest (member-type-members car-type))) + (or (symbolp (first (member-type-members car-type))) + (numberp (first (member-type-members car-type))) + (and (listp (first (member-type-members + car-type))) + (numberp (first (first (member-type-members + car-type)))))) + (good-cons-type-p (cons-type-cdr-type cons-type)))))) + (unconsify-type (good-cons-type) + ;; Convert the "printed" respresentation of a cons + ;; specifier into a type specifier. That is, the + ;; specifier (CONS (EQL SIGNED-BYTE) (CONS (EQL 16) + ;; NULL)) is converted to (SIGNED-BYTE 16). + (cond ((or (null good-cons-type) + (eq good-cons-type 'null)) + nil) + ((and (eq (first good-cons-type) 'cons) + (eq (first (second good-cons-type)) 'member)) + `(,(second (second good-cons-type)) + ,@(unconsify-type (caddr good-cons-type)))))) + (coerceable-p (c-type) + ;; Can the value be coerced to the given type? Coerce is + ;; complicated, so we don't handle every possible case + ;; here---just the most common and easiest cases: + ;; + ;; * Any REAL can be coerced to a FLOAT type. + ;; * Any NUMBER can be coerced to a (COMPLEX + ;; SINGLE/DOUBLE-FLOAT). + ;; + ;; FIXME I: we should also be able to deal with characters + ;; here. + ;; + ;; FIXME II: I'm not sure that anything is necessary + ;; here, at least while COMPLEX is not a specialized + ;; array element type in the system. Reasoning: if + ;; something cannot be coerced to the requested type, an + ;; error will be raised (and so any downstream compiled + ;; code on the assumption of the returned type is + ;; unreachable). If something can, then it will be of + ;; the requested type, because (by assumption) COMPLEX + ;; (and other difficult types like (COMPLEX INTEGER) + ;; aren't specialized types. + (let ((coerced-type c-type)) + (or (and (subtypep coerced-type 'float) + (csubtypep value-type (specifier-type 'real))) + (and (subtypep coerced-type + '(or (complex single-float) + (complex double-float))) + (csubtypep value-type (specifier-type 'number)))))) + (process-types (type) + ;; FIXME: This needs some work because we should be able + ;; to derive the resulting type better than just the + ;; type arg of coerce. That is, if X is (INTEGER 10 + ;; 20), then (COERCE X 'DOUBLE-FLOAT) should say + ;; (DOUBLE-FLOAT 10d0 20d0) instead of just + ;; double-float. + (cond ((member-type-p type) + (let ((members (member-type-members type))) + (if (every #'coerceable-p members) + (specifier-type `(or ,@members)) + *universal-type*))) + ((and (cons-type-p type) + (good-cons-type-p type)) + (let ((c-type (unconsify-type (type-specifier type)))) + (if (coerceable-p c-type) + (specifier-type c-type) + *universal-type*))) + (t + *universal-type*)))) + (cond ((union-type-p type-type) + (apply #'type-union (mapcar #'process-types + (union-type-types type-type)))) + ((or (member-type-p type-type) + (cons-type-p type-type)) + (process-types type-type)) + (t + *universal-type*))))))) (defoptimizer (compile derive-type) ((nameoid function)) (when (csubtypep (lvar-type nameoid) - (specifier-type 'null)) + (specifier-type 'null)) (values-specifier-type '(values function boolean boolean)))) ;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving @@ -3833,22 +3833,22 @@ `(cons (eql ,(car list)) ,(consify (rest list))))) (get-element-type (a) (let ((element-type - (type-specifier (array-type-specialized-element-type a)))) + (type-specifier (array-type-specialized-element-type a)))) (cond ((eq element-type '*) (specifier-type 'type-specifier)) - ((symbolp element-type) + ((symbolp element-type) (make-member-type :members (list element-type))) ((consp element-type) (specifier-type (consify element-type))) (t (error "can't understand type ~S~%" element-type)))))) (cond ((array-type-p array-type) - (get-element-type array-type)) - ((union-type-p array-type) + (get-element-type array-type)) + ((union-type-p array-type) (apply #'type-union (mapcar #'get-element-type (union-type-types array-type)))) - (t - *universal-type*))))) + (t + *universal-type*))))) ;;; Like CMU CL, we use HEAPSORT. However, other than that, this code ;;; isn't really related to the CMU CL code, since instead of trying @@ -3862,77 +3862,77 @@ ;; code has been written from scratch following Chapter 7 of ;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. `(macrolet ((%index (x) `(truly-the index ,x)) - (%parent (i) `(ash ,i -1)) - (%left (i) `(%index (ash ,i 1))) - (%right (i) `(%index (1+ (ash ,i 1)))) - (%heapify (i) - `(do* ((i ,i) - (left (%left i) (%left i))) - ((> left current-heap-size)) - (declare (type index i left)) - (let* ((i-elt (%elt i)) - (i-key (funcall keyfun i-elt)) - (left-elt (%elt left)) - (left-key (funcall keyfun left-elt))) - (multiple-value-bind (large large-elt large-key) - (if (funcall ,',predicate i-key left-key) - (values left left-elt left-key) - (values i i-elt i-key)) - (let ((right (%right i))) - (multiple-value-bind (largest largest-elt) - (if (> right current-heap-size) - (values large large-elt) - (let* ((right-elt (%elt right)) - (right-key (funcall keyfun right-elt))) - (if (funcall ,',predicate large-key right-key) - (values right right-elt) - (values large large-elt)))) - (cond ((= largest i) - (return)) - (t - (setf (%elt i) largest-elt - (%elt largest) i-elt - i largest))))))))) - (%sort-vector (keyfun &optional (vtype 'vector)) - `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had - ;; trouble getting type inference to - ;; propagate all the way through this - ;; tangled mess of inlining. The TRULY-THE - ;; here works around that. -- WHN - (%elt (i) - `(aref (truly-the ,',vtype ,',',vector) - (%index (+ (%index ,i) start-1))))) - (let (;; Heaps prefer 1-based addressing. - (start-1 (1- ,',start)) - (current-heap-size (- ,',end ,',start)) - (keyfun ,keyfun)) - (declare (type (integer -1 #.(1- most-positive-fixnum)) - start-1)) - (declare (type index current-heap-size)) - (declare (type function keyfun)) - (loop for i of-type index - from (ash current-heap-size -1) downto 1 do - (%heapify i)) - (loop - (when (< current-heap-size 2) - (return)) - (rotatef (%elt 1) (%elt current-heap-size)) - (decf current-heap-size) - (%heapify 1)))))) + (%parent (i) `(ash ,i -1)) + (%left (i) `(%index (ash ,i 1))) + (%right (i) `(%index (1+ (ash ,i 1)))) + (%heapify (i) + `(do* ((i ,i) + (left (%left i) (%left i))) + ((> left current-heap-size)) + (declare (type index i left)) + (let* ((i-elt (%elt i)) + (i-key (funcall keyfun i-elt)) + (left-elt (%elt left)) + (left-key (funcall keyfun left-elt))) + (multiple-value-bind (large large-elt large-key) + (if (funcall ,',predicate i-key left-key) + (values left left-elt left-key) + (values i i-elt i-key)) + (let ((right (%right i))) + (multiple-value-bind (largest largest-elt) + (if (> right current-heap-size) + (values large large-elt) + (let* ((right-elt (%elt right)) + (right-key (funcall keyfun right-elt))) + (if (funcall ,',predicate large-key right-key) + (values right right-elt) + (values large large-elt)))) + (cond ((= largest i) + (return)) + (t + (setf (%elt i) largest-elt + (%elt largest) i-elt + i largest))))))))) + (%sort-vector (keyfun &optional (vtype 'vector)) + `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had + ;; trouble getting type inference to + ;; propagate all the way through this + ;; tangled mess of inlining. The TRULY-THE + ;; here works around that. -- WHN + (%elt (i) + `(aref (truly-the ,',vtype ,',',vector) + (%index (+ (%index ,i) start-1))))) + (let (;; Heaps prefer 1-based addressing. + (start-1 (1- ,',start)) + (current-heap-size (- ,',end ,',start)) + (keyfun ,keyfun)) + (declare (type (integer -1 #.(1- most-positive-fixnum)) + start-1)) + (declare (type index current-heap-size)) + (declare (type function keyfun)) + (loop for i of-type index + from (ash current-heap-size -1) downto 1 do + (%heapify i)) + (loop + (when (< current-heap-size 2) + (return)) + (rotatef (%elt 1) (%elt current-heap-size)) + (decf current-heap-size) + (%heapify 1)))))) (if (typep ,vector 'simple-vector) - ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is - ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA. - (if (null ,key) - ;; Special-casing the KEY=NIL case lets us avoid some - ;; function calls. - (%sort-vector #'identity simple-vector) - (%sort-vector ,key simple-vector)) - ;; It's hard to anticipate many speed-critical applications for - ;; sorting vector types other than (VECTOR T), so we just lump - ;; them all together in one slow dynamically typed mess. - (locally - (declare (optimize (speed 2) (space 2) (inhibit-warnings 3))) - (%sort-vector (or ,key #'identity)))))) + ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is + ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA. + (if (null ,key) + ;; Special-casing the KEY=NIL case lets us avoid some + ;; function calls. + (%sort-vector #'identity simple-vector) + (%sort-vector ,key simple-vector)) + ;; It's hard to anticipate many speed-critical applications for + ;; sorting vector types other than (VECTOR T), so we just lump + ;; them all together in one slow dynamically typed mess. + (locally + (declare (optimize (speed 2) (space 2) (inhibit-warnings 3))) + (%sort-vector (or ,key #'identity)))))) ;;;; debuggers' little helpers @@ -3945,8 +3945,8 @@ ;;; (let ((bound (ash 1 (1- s)))) ;;; (sb-c::/report-lvar bound "BOUND") ;;; (let ((x (- bound)) -;;; (y (1- bound))) -;;; (sb-c::/report-lvar x "X") +;;; (y (1- bound))) +;;; (sb-c::/report-lvar x "X") ;;; (sb-c::/report-lvar x "Y")) ;;; `(integer ,(- bound) ,(1- bound))))) ;;; (The DEFTRANSFORM doesn't do anything but report at compile time, diff --git a/src/compiler/sset.lisp b/src/compiler/sset.lisp index 4f7f1eb..609f555 100644 --- a/src/compiler/sset.lisp +++ b/src/compiler/sset.lisp @@ -20,7 +20,7 @@ ;;; that no ordering has been assigned yet (although an ordering must ;;; be assigned before doing set operations.) (def!struct (sset-element (:constructor nil) - (:copier nil)) + (:copier nil)) (number nil :type (or index null))) (defstruct (sset (:copier nil)) @@ -42,18 +42,18 @@ (declaim (ftype (sfunction (sset-element sset) boolean) sset-adjoin)) (defun sset-adjoin (element set) (let ((number (sset-element-number element)) - (elements (sset-elements set))) + (elements (sset-elements set))) (do ((prev elements current) - (current (cdr elements) (cdr current))) - ((null current) - (setf (cdr prev) (list element)) - t) + (current (cdr elements) (cdr current))) + ((null current) + (setf (cdr prev) (list element)) + t) (let ((el (car current))) - (when (>= (sset-element-number el) number) - (when (eq el element) - (return nil)) - (setf (cdr prev) (cons element current)) - (return t)))))) + (when (>= (sset-element-number el) number) + (when (eq el element) + (return nil)) + (setf (cdr prev) (cons element current)) + (return t)))))) ;;; Destructively remove ELEMENT from SET. If element was in the set, ;;; then return true, otherwise return false. @@ -61,11 +61,11 @@ (defun sset-delete (element set) (let ((elements (sset-elements set))) (do ((prev elements current) - (current (cdr elements) (cdr current))) - ((null current) nil) + (current (cdr elements) (cdr current))) + ((null current) nil) (when (eq (car current) element) - (setf (cdr prev) (cdr current)) - (return t))))) + (setf (cdr prev) (cdr current)) + (return t))))) ;;; Return true if ELEMENT is in SET, false otherwise. (declaim (ftype (sfunction (sset-element sset) boolean) sset-member)) @@ -91,69 +91,69 @@ ;;; destructively modifying SET1. We return true if SET1 was modified, ;;; false otherwise. (declaim (ftype (sfunction (sset sset) boolean) sset-union sset-intersection - sset-difference)) + sset-difference)) (defun sset-union (set1 set2) (let* ((prev-el1 (sset-elements set1)) - (el1 (cdr prev-el1)) - (changed nil)) + (el1 (cdr prev-el1)) + (changed nil)) (do ((el2 (cdr (sset-elements set2)) (cdr el2))) - ((null el2) changed) + ((null el2) changed) (let* ((e (car el2)) - (num2 (sset-element-number e))) - (loop - (when (null el1) - (setf (cdr prev-el1) (copy-list el2)) - (return-from sset-union t)) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (if (> num1 num2) - (let ((new (cons e el1))) - (setf (cdr prev-el1) new) - (setq prev-el1 new - changed t)) - (shiftf prev-el1 el1 (cdr el1))) - (return)) - (shiftf prev-el1 el1 (cdr el1)))))))) + (num2 (sset-element-number e))) + (loop + (when (null el1) + (setf (cdr prev-el1) (copy-list el2)) + (return-from sset-union t)) + (let ((num1 (sset-element-number (car el1)))) + (when (>= num1 num2) + (if (> num1 num2) + (let ((new (cons e el1))) + (setf (cdr prev-el1) new) + (setq prev-el1 new + changed t)) + (shiftf prev-el1 el1 (cdr el1))) + (return)) + (shiftf prev-el1 el1 (cdr el1)))))))) (defun sset-intersection (set1 set2) (let* ((prev-el1 (sset-elements set1)) - (el1 (cdr prev-el1)) - (changed nil)) + (el1 (cdr prev-el1)) + (changed nil)) (do ((el2 (cdr (sset-elements set2)) (cdr el2))) - ((null el2) - (cond (el1 - (setf (cdr prev-el1) nil) - t) - (t changed))) + ((null el2) + (cond (el1 + (setf (cdr prev-el1) nil) + t) + (t changed))) (let ((num2 (sset-element-number (car el2)))) - (loop - (when (null el1) - (return-from sset-intersection changed)) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (when (= num1 num2) - (shiftf prev-el1 el1 (cdr el1))) - (return)) - (pop el1) - (setf (cdr prev-el1) el1) - (setq changed t))))))) + (loop + (when (null el1) + (return-from sset-intersection changed)) + (let ((num1 (sset-element-number (car el1)))) + (when (>= num1 num2) + (when (= num1 num2) + (shiftf prev-el1 el1 (cdr el1))) + (return)) + (pop el1) + (setf (cdr prev-el1) el1) + (setq changed t))))))) (defun sset-difference (set1 set2) (let* ((prev-el1 (sset-elements set1)) - (el1 (cdr prev-el1)) - (changed nil)) + (el1 (cdr prev-el1)) + (changed nil)) (do ((el2 (cdr (sset-elements set2)) (cdr el2))) - ((null el2) changed) + ((null el2) changed) (let ((num2 (sset-element-number (car el2)))) - (loop - (when (null el1) - (return-from sset-difference changed)) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (when (= num1 num2) - (pop el1) - (setf (cdr prev-el1) el1) - (setq changed t)) - (return)) - (shiftf prev-el1 el1 (cdr el1)))))))) + (loop + (when (null el1) + (return-from sset-difference changed)) + (let ((num1 (sset-element-number (car el1)))) + (when (>= num1 num2) + (when (= num1 num2) + (pop el1) + (setf (cdr prev-el1) el1) + (setq changed t)) + (return)) + (shiftf prev-el1 el1 (cdr el1)))))))) ;;; Destructively modify SET1 to include its union with the difference ;;; of SET2 and SET3. We return true if SET1 was modified, false @@ -161,59 +161,59 @@ (declaim (ftype (sfunction (sset sset sset) boolean) sset-union-of-difference)) (defun sset-union-of-difference (set1 set2 set3) (let* ((prev-el1 (sset-elements set1)) - (el1 (cdr prev-el1)) - (el3 (cdr (sset-elements set3))) - (changed nil)) + (el1 (cdr prev-el1)) + (el3 (cdr (sset-elements set3))) + (changed nil)) (do ((el2 (cdr (sset-elements set2)) (cdr el2))) - ((null el2) changed) + ((null el2) changed) (let* ((e (car el2)) - (num2 (sset-element-number e))) - (loop - (when (null el3) - (loop - (when (null el1) - (setf (cdr prev-el1) (copy-list el2)) - (return-from sset-union-of-difference t)) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (if (> num1 num2) - (let ((new (cons e el1))) - (setf (cdr prev-el1) new) - (setq prev-el1 new changed t)) - (shiftf prev-el1 el1 (cdr el1))) - (return)) - (shiftf prev-el1 el1 (cdr el1)))) - (return)) - (let ((num3 (sset-element-number (car el3)))) - (when (<= num2 num3) - (unless (= num2 num3) - (loop - (when (null el1) - (do ((el2 el2 (cdr el2))) - ((null el2) - (return-from sset-union-of-difference changed)) - (let* ((e (car el2)) - (num2 (sset-element-number e))) - (loop - (when (null el3) - (setf (cdr prev-el1) (copy-list el2)) - (return-from sset-union-of-difference t)) - (setq num3 (sset-element-number (car el3))) - (when (<= num2 num3) - (unless (= num2 num3) - (let ((new (cons e el1))) - (setf (cdr prev-el1) new) - (setq prev-el1 new changed t))) - (return)) - (pop el3))))) - (let ((num1 (sset-element-number (car el1)))) - (when (>= num1 num2) - (if (> num1 num2) - (let ((new (cons e el1))) - (setf (cdr prev-el1) new) - (setq prev-el1 new changed t)) - (shiftf prev-el1 el1 (cdr el1))) - (return)) - (shiftf prev-el1 el1 (cdr el1))))) - (return))) - (pop el3)))))) + (num2 (sset-element-number e))) + (loop + (when (null el3) + (loop + (when (null el1) + (setf (cdr prev-el1) (copy-list el2)) + (return-from sset-union-of-difference t)) + (let ((num1 (sset-element-number (car el1)))) + (when (>= num1 num2) + (if (> num1 num2) + (let ((new (cons e el1))) + (setf (cdr prev-el1) new) + (setq prev-el1 new changed t)) + (shiftf prev-el1 el1 (cdr el1))) + (return)) + (shiftf prev-el1 el1 (cdr el1)))) + (return)) + (let ((num3 (sset-element-number (car el3)))) + (when (<= num2 num3) + (unless (= num2 num3) + (loop + (when (null el1) + (do ((el2 el2 (cdr el2))) + ((null el2) + (return-from sset-union-of-difference changed)) + (let* ((e (car el2)) + (num2 (sset-element-number e))) + (loop + (when (null el3) + (setf (cdr prev-el1) (copy-list el2)) + (return-from sset-union-of-difference t)) + (setq num3 (sset-element-number (car el3))) + (when (<= num2 num3) + (unless (= num2 num3) + (let ((new (cons e el1))) + (setf (cdr prev-el1) new) + (setq prev-el1 new changed t))) + (return)) + (pop el3))))) + (let ((num1 (sset-element-number (car el1)))) + (when (>= num1 num2) + (if (> num1 num2) + (let ((new (cons e el1))) + (setf (cdr prev-el1) new) + (setq prev-el1 new changed t)) + (shiftf prev-el1 el1 (cdr el1))) + (return)) + (shiftf prev-el1 el1 (cdr el1))))) + (return))) + (pop el3)))))) diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index b2b8a11..4ac4c7a 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -22,17 +22,17 @@ ;;; invariant that all pushes come after the last pop. (defun find-pushed-lvars (block) (let* ((2block (block-info block)) - (popped (ir2-block-popped 2block)) - (last-pop (if popped - (lvar-dest (car (last popped))) - nil))) + (popped (ir2-block-popped 2block)) + (last-pop (if popped + (lvar-dest (car (last popped))) + nil))) (collect ((pushed)) (let ((saw-last nil)) - (do-nodes (node lvar block) - (when (eq node last-pop) - (setq saw-last t)) + (do-nodes (node lvar block) + (when (eq node last-pop) + (setq saw-last t)) - (when (and lvar + (when (and lvar (or (lvar-dynamic-extent lvar) (let ((dest (lvar-dest lvar)) (2lvar (lvar-info lvar))) @@ -277,9 +277,9 @@ (collect ((res nil adjoin)) (dolist (rec receivers) (dolist (pop (ir2-block-popped (block-info rec))) - (do-uses (use pop) - (unless (exit-p use) - (res (node-block use)))))) + (do-uses (use pop) + (unless (exit-p use) + (res (node-block use)))))) (dolist (dx-lvar dx-lvars) (do-uses (use dx-lvar) (res (node-block use)))) @@ -293,8 +293,8 @@ (defun stack-analyze (component) (declare (type component component)) (let* ((2comp (component-info component)) - (receivers (ir2-component-values-receivers 2comp)) - (generators (find-pushing-blocks receivers + (receivers (ir2-component-values-receivers 2comp)) + (generators (find-pushing-blocks receivers (component-dx-lvars component)))) (dolist (block generators) @@ -311,10 +311,10 @@ (do-blocks (block component) (let ((top (ir2-block-end-stack (block-info block)))) - (dolist (succ (block-succ block)) - (when (and (block-start succ) - (not (eq (ir2-block-start-stack (block-info succ)) - top))) - (discard-unused-values block succ)))))) + (dolist (succ (block-succ block)) + (when (and (block-start succ) + (not (eq (ir2-block-start-stack (block-info succ)) + top))) + (discard-unused-values block succ)))))) (values)) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 35b405b..9bcfd33 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -23,10 +23,10 @@ (defun inst-specializes-p (special general) (declare (type instruction special general)) (let ((smask (inst-mask special)) - (gmask (inst-mask general))) + (gmask (inst-mask general))) (and (dchunk= (inst-id general) - (dchunk-and (inst-id special) gmask)) - (dchunk-strict-superset-p smask gmask)))) + (dchunk-and (inst-id special) gmask)) + (dchunk-strict-superset-p smask gmask)))) ;;; a bit arbitrary, but should work ok... ;;; @@ -56,20 +56,20 @@ (let ((masters (copy-list insts))) (dolist (possible-master insts) (dolist (possible-specializer insts) - (unless (or (eq possible-specializer possible-master) - (inst-specializes-p possible-specializer possible-master)) - (setf masters (delete possible-master masters)) - (return) ; exit the inner loop - ))) + (unless (or (eq possible-specializer possible-master) + (inst-specializes-p possible-specializer possible-master)) + (setf masters (delete possible-master masters)) + (return) ; exit the inner loop + ))) (cond ((null masters) - (specialization-error insts)) - ((cdr masters) - (error "multiple specializing masters: ~S" masters)) - (t - (let ((master (car masters))) - (setf (inst-specializers master) - (order-specializers (remove master insts))) - master))))) + (specialization-error insts)) + ((cdr masters) + (error "multiple specializing masters: ~S" masters)) + (t + (let ((master (car masters))) + (setf (inst-specializers master) + (order-specializers (remove master insts))) + master))))) ;;;; choosing an instruction @@ -78,7 +78,7 @@ ;;; Return non-NIL if all constant-bits in INST match CHUNK. (defun inst-matches-p (inst chunk) (declare (type instruction inst) - (type dchunk chunk)) + (type dchunk chunk)) (dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst))) ;;; Given an instruction object, INST, and a bit-pattern, CHUNK, pick @@ -86,11 +86,11 @@ ;;; constraints are met by CHUNK. If none do, then return INST. (defun choose-inst-specialization (inst chunk) (declare (type instruction inst) - (type dchunk chunk)) + (type dchunk chunk)) (or (dolist (spec (inst-specializers inst) nil) - (declare (type instruction spec)) - (when (inst-matches-p spec chunk) - (return spec))) + (declare (type instruction spec)) + (when (inst-matches-p spec chunk) + (return spec))) inst)) ;;;; searching for an instruction in instruction space @@ -99,21 +99,21 @@ ;;; bit-pattern CHUNK, or NIL if there isn't one. (defun find-inst (chunk inst-space) (declare (type dchunk chunk) - (type (or null inst-space instruction) inst-space)) + (type (or null inst-space instruction) inst-space)) (etypecase inst-space (null nil) (instruction (if (inst-matches-p inst-space chunk) - (choose-inst-specialization inst-space chunk) - nil)) + (choose-inst-specialization inst-space chunk) + nil)) (inst-space (let* ((mask (ispace-valid-mask inst-space)) - (id (dchunk-and mask chunk))) + (id (dchunk-and mask chunk))) (declare (type dchunk id mask)) (dolist (choice (ispace-choices inst-space)) - (declare (type inst-space-choice choice)) - (when (dchunk= id (ischoice-common-id choice)) - (return (find-inst chunk (ischoice-subspace choice))))))))) + (declare (type inst-space-choice choice)) + (when (dchunk= id (ischoice-common-id choice)) + (return (find-inst chunk (ischoice-subspace choice))))))))) ;;;; building the instruction space @@ -130,37 +130,37 @@ ;; bits, TRY-SPECIALIZING is called, which handles the cases of many ;; variations on a single instruction. (declare (type list insts) - (type dchunk initial-mask)) + (type dchunk initial-mask)) (cond ((null insts) - nil) - ((null (cdr insts)) - (car insts)) - (t - (let ((vmask (dchunk-copy initial-mask))) - (dolist (inst insts) - (dchunk-andf vmask (inst-mask inst))) - (if (dchunk-zerop vmask) - (try-specializing insts) - (let ((buckets nil)) - (dolist (inst insts) - (let* ((common-id (dchunk-and (inst-id inst) vmask)) - (bucket (assoc common-id buckets :test #'dchunk=))) - (cond ((null bucket) - (push (list common-id inst) buckets)) - (t - (push inst (cdr bucket)))))) - (let ((submask (dchunk-clear initial-mask vmask))) - (if (= (length buckets) 1) - (try-specializing insts) - (make-inst-space - :valid-mask vmask - :choices (mapcar (lambda (bucket) - (make-inst-space-choice - :subspace (build-inst-space - (cdr bucket) - submask) - :common-id (car bucket))) - buckets)))))))))) + nil) + ((null (cdr insts)) + (car insts)) + (t + (let ((vmask (dchunk-copy initial-mask))) + (dolist (inst insts) + (dchunk-andf vmask (inst-mask inst))) + (if (dchunk-zerop vmask) + (try-specializing insts) + (let ((buckets nil)) + (dolist (inst insts) + (let* ((common-id (dchunk-and (inst-id inst) vmask)) + (bucket (assoc common-id buckets :test #'dchunk=))) + (cond ((null bucket) + (push (list common-id inst) buckets)) + (t + (push inst (cdr bucket)))))) + (let ((submask (dchunk-clear initial-mask vmask))) + (if (= (length buckets) 1) + (try-specializing insts) + (make-inst-space + :valid-mask vmask + :choices (mapcar (lambda (bucket) + (make-inst-space-choice + :subspace (build-inst-space + (cdr bucket) + submask) + :common-id (car bucket))) + buckets)))))))))) ;;;; an inst-space printer for debugging purposes @@ -168,15 +168,15 @@ (do ((bit (1- word-size) (1- bit))) ((< bit 0)) (write-char (cond ((logbitp bit mask) - (if (logbitp bit num) #\1 #\0)) - ((< bit show) #\x) - (t #\space))))) + (if (logbitp bit num) #\1 #\0)) + ((< bit show) #\x) + (t #\space))))) (defun print-inst-bits (inst) (print-masked-binary (inst-id inst) - (inst-mask inst) - dchunk-bits - (bytes-to-bits (inst-length inst)))) + (inst-mask inst) + dchunk-bits + (bytes-to-bits (inst-length inst)))) ;;; Print a nicely-formatted version of INST-SPACE. (defun print-inst-space (inst-space &optional (indent 0)) @@ -184,8 +184,8 @@ (null) (instruction (format t "~Vt[~A(~A)~40T" indent - (inst-name inst-space) - (inst-format-name inst-space)) + (inst-name inst-space) + (inst-format-name inst-space)) (print-inst-bits inst-space) (dolist (inst (inst-specializers inst-space)) (format t "~%~Vt:~A~40T" indent (inst-name inst)) @@ -194,46 +194,46 @@ (terpri)) (inst-space (format t "~Vt---- ~8,'0X ----~%" - indent - (ispace-valid-mask inst-space)) + indent + (ispace-valid-mask inst-space)) (map nil - (lambda (choice) - (format t "~Vt~8,'0X ==>~%" - (+ 2 indent) - (ischoice-common-id choice)) - (print-inst-space (ischoice-subspace choice) - (+ 4 indent))) - (ispace-choices inst-space))))) + (lambda (choice) + (format t "~Vt~8,'0X ==>~%" + (+ 2 indent) + (ischoice-common-id choice)) + (print-inst-space (ischoice-subspace choice) + (+ 4 indent))) + (ispace-choices inst-space))))) ;;;; (The actual disassembly part follows.) ;;; Code object layout: -;;; header-word -;;; code-size (starting from first inst, in words) -;;; entry-points (points to first function header) -;;; debug-info -;;; trace-table-offset (starting from first inst, in bytes) -;;; constant1 -;;; constant2 -;;; ... -;;; -;;; start of instructions -;;; ... -;;; fun-headers and lra's buried in here randomly -;;; ... -;;; start of trace-table -;;; +;;; header-word +;;; code-size (starting from first inst, in words) +;;; entry-points (points to first function header) +;;; debug-info +;;; trace-table-offset (starting from first inst, in bytes) +;;; constant1 +;;; constant2 +;;; ... +;;; +;;; start of instructions +;;; ... +;;; fun-headers and lra's buried in here randomly +;;; ... +;;; start of trace-table +;;; ;;; ;;; Function header layout (dual word aligned): -;;; header-word -;;; self pointer -;;; next pointer (next function header) -;;; name -;;; arglist -;;; type +;;; header-word +;;; self pointer +;;; next pointer (next function header) +;;; name +;;; arglist +;;; type ;;; ;;; LRA layout (dual word aligned): -;;; header-word +;;; header-word #!-sb-fluid (declaim (inline words-to-bytes bytes-to-words)) @@ -257,10 +257,10 @@ (before-address nil :type (member t nil))) (defstruct (segment (:conc-name seg-) - (:constructor %make-segment) - (:copier nil)) + (:constructor %make-segment) + (:copier nil)) (sap-maker (missing-arg) - :type (function () sb!sys:system-area-pointer)) + :type (function () sb!sys:system-area-pointer)) (length 0 :type disassem-length) (virtual-location 0 :type address) (storage-info nil :type (or null storage-info)) @@ -270,11 +270,11 @@ (print-unreadable-object (seg stream :type t) (let ((addr (sb!sys:sap-int (funcall (seg-sap-maker seg))))) (format stream "#X~X[~W]~:[ (#X~X)~;~*~]~@[ in ~S~]" - addr - (seg-length seg) - (= (seg-virtual-location seg) addr) - (seg-virtual-location seg) - (seg-code seg))))) + addr + (seg-length seg) + (= (seg-virtual-location seg) addr) + (seg-virtual-location seg) + (seg-code seg))))) ;;;; function ops @@ -319,7 +319,7 @@ (defun code-inst-area-length (code-component) (declare (type sb!kernel:code-component code-component)) (sb!kernel:code-header-ref code-component - sb!vm:code-trace-table-offset-slot)) + sb!vm:code-trace-table-offset-slot)) ;;; Return the address of the instruction area in CODE-COMPONENT. (defun code-inst-area-address (code-component) @@ -332,54 +332,54 @@ (defun code-first-function (code-component) (declare (type sb!kernel:code-component code-component)) (sb!kernel:code-header-ref code-component - sb!vm:code-trace-table-offset-slot)) + sb!vm:code-trace-table-offset-slot)) |# (defun segment-offs-to-code-offs (offset segment) (sb!sys:without-gcing (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment)))) - (code-addr - (logandc1 sb!vm:lowtag-mask - (sb!kernel:get-lisp-obj-address (seg-code segment)))) - (addr (+ offset seg-base-addr))) + (code-addr + (logandc1 sb!vm:lowtag-mask + (sb!kernel:get-lisp-obj-address (seg-code segment)))) + (addr (+ offset seg-base-addr))) (declare (type address seg-base-addr code-addr addr)) (- addr code-addr)))) (defun code-offs-to-segment-offs (offset segment) (sb!sys:without-gcing (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment)))) - (code-addr - (logandc1 sb!vm:lowtag-mask - (sb!kernel:get-lisp-obj-address (seg-code segment)))) - (addr (+ offset code-addr))) + (code-addr + (logandc1 sb!vm:lowtag-mask + (sb!kernel:get-lisp-obj-address (seg-code segment)))) + (addr (+ offset code-addr))) (declare (type address seg-base-addr code-addr addr)) (- addr seg-base-addr)))) (defun code-insts-offs-to-segment-offs (offset segment) (sb!sys:without-gcing (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment)))) - (code-insts-addr - (sb!sys:sap-int (sb!kernel:code-instructions (seg-code segment)))) - (addr (+ offset code-insts-addr))) + (code-insts-addr + (sb!sys:sap-int (sb!kernel:code-instructions (seg-code segment)))) + (addr (+ offset code-insts-addr))) (declare (type address seg-base-addr code-insts-addr addr)) (- addr seg-base-addr)))) (defun lra-hook (chunk stream dstate) (declare (type dchunk chunk) - (ignore chunk) - (type (or null stream) stream) - (type disassem-state dstate)) + (ignore chunk) + (type (or null stream) stream) + (type disassem-state dstate)) (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate)) - (* 2 sb!vm:n-word-bytes)) - ;; Check type. - (= (sb!sys:sap-ref-8 (dstate-segment-sap dstate) - (if (eq (dstate-byte-order dstate) - :little-endian) - (dstate-cur-offs dstate) - (+ (dstate-cur-offs dstate) - (1- lra-size)))) - sb!vm:return-pc-header-widetag)) + (dstate-cur-offs dstate)) + (* 2 sb!vm:n-word-bytes)) + ;; Check type. + (= (sb!sys:sap-ref-8 (dstate-segment-sap dstate) + (if (eq (dstate-byte-order dstate) + :little-endian) + (dstate-cur-offs dstate) + (+ (dstate-cur-offs dstate) + (1- lra-size)))) + sb!vm:return-pc-header-widetag)) (unless (null stream) (note "possible LRA header" dstate))) nil) @@ -388,104 +388,104 @@ ;;; current location in DSTATE to STREAM. (defun fun-header-hook (stream dstate) (declare (type (or null stream) stream) - (type disassem-state dstate)) + (type disassem-state dstate)) (unless (null stream) (let* ((seg (dstate-segment dstate)) - (code (seg-code seg)) - (woffs - (bytes-to-words - (segment-offs-to-code-offs (dstate-cur-offs dstate) seg))) - (name - (sb!kernel:code-header-ref code - (+ woffs - sb!vm:simple-fun-name-slot))) - (args - (sb!kernel:code-header-ref code - (+ woffs - sb!vm:simple-fun-arglist-slot))) - (type - (sb!kernel:code-header-ref code - (+ woffs - sb!vm:simple-fun-type-slot)))) + (code (seg-code seg)) + (woffs + (bytes-to-words + (segment-offs-to-code-offs (dstate-cur-offs dstate) seg))) + (name + (sb!kernel:code-header-ref code + (+ woffs + sb!vm:simple-fun-name-slot))) + (args + (sb!kernel:code-header-ref code + (+ woffs + sb!vm:simple-fun-arglist-slot))) + (type + (sb!kernel:code-header-ref code + (+ woffs + sb!vm:simple-fun-type-slot)))) (format stream ".~A ~S~:A" 'entry name args) (note (lambda (stream) - (format stream "~:S" type)) ; use format to print NIL as () - dstate))) + (format stream "~:S" type)) ; use format to print NIL as () + dstate))) (incf (dstate-next-offs dstate) - (words-to-bytes sb!vm:simple-fun-code-offset))) + (words-to-bytes sb!vm:simple-fun-code-offset))) (defun alignment-hook (chunk stream dstate) (declare (type dchunk chunk) - (ignore chunk) - (type (or null stream) stream) - (type disassem-state dstate)) + (ignore chunk) + (type (or null stream) stream) + (type disassem-state dstate)) (let ((location - (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate))) - (alignment (dstate-alignment dstate))) + (+ (seg-virtual-location (dstate-segment dstate)) + (dstate-cur-offs dstate))) + (alignment (dstate-alignment dstate))) (unless (aligned-p location alignment) (when stream - (format stream "~A~Vt~W~%" '.align - (dstate-argument-column dstate) - alignment)) + (format stream "~A~Vt~W~%" '.align + (dstate-argument-column dstate) + alignment)) (incf(dstate-next-offs dstate) - (- (align location alignment) location))) + (- (align location alignment) location))) nil)) (defun rewind-current-segment (dstate segment) (declare (type disassem-state dstate) - (type segment segment)) + (type segment segment)) (setf (dstate-segment dstate) segment) (setf (dstate-cur-offs-hooks dstate) - (stable-sort (nreverse (copy-list (seg-hooks segment))) - (lambda (oh1 oh2) - (or (< (offs-hook-offset oh1) (offs-hook-offset oh2)) - (and (= (offs-hook-offset oh1) - (offs-hook-offset oh2)) - (offs-hook-before-address oh1) - (not (offs-hook-before-address oh2))))))) + (stable-sort (nreverse (copy-list (seg-hooks segment))) + (lambda (oh1 oh2) + (or (< (offs-hook-offset oh1) (offs-hook-offset oh2)) + (and (= (offs-hook-offset oh1) + (offs-hook-offset oh2)) + (offs-hook-before-address oh1) + (not (offs-hook-before-address oh2))))))) (setf (dstate-cur-offs dstate) 0) (setf (dstate-cur-labels dstate) (dstate-labels dstate))) (defun call-offs-hooks (before-address stream dstate) (declare (type (or null stream) stream) - (type disassem-state dstate)) + (type disassem-state dstate)) (let ((cur-offs (dstate-cur-offs dstate))) (setf (dstate-next-offs dstate) cur-offs) (loop (let ((next-hook (car (dstate-cur-offs-hooks dstate)))) - (when (null next-hook) - (return)) - (let ((hook-offs (offs-hook-offset next-hook))) - (when (or (> hook-offs cur-offs) - (and (= hook-offs cur-offs) - before-address - (not (offs-hook-before-address next-hook)))) - (return)) - (unless (< hook-offs cur-offs) - (funcall (offs-hook-fun next-hook) stream dstate)) - (pop (dstate-cur-offs-hooks dstate)) - (unless (= (dstate-next-offs dstate) cur-offs) - (return))))))) + (when (null next-hook) + (return)) + (let ((hook-offs (offs-hook-offset next-hook))) + (when (or (> hook-offs cur-offs) + (and (= hook-offs cur-offs) + before-address + (not (offs-hook-before-address next-hook)))) + (return)) + (unless (< hook-offs cur-offs) + (funcall (offs-hook-fun next-hook) stream dstate)) + (pop (dstate-cur-offs-hooks dstate)) + (unless (= (dstate-next-offs dstate) cur-offs) + (return))))))) (defun call-fun-hooks (chunk stream dstate) (let ((hooks (dstate-fun-hooks dstate)) - (cur-offs (dstate-cur-offs dstate))) + (cur-offs (dstate-cur-offs dstate))) (setf (dstate-next-offs dstate) cur-offs) (dolist (hook hooks nil) (let ((prefix-p (funcall hook chunk stream dstate))) - (unless (= (dstate-next-offs dstate) cur-offs) - (return prefix-p)))))) + (unless (= (dstate-next-offs dstate) cur-offs) + (return prefix-p)))))) (defun handle-bogus-instruction (stream dstate) (let ((alignment (dstate-alignment dstate))) (unless (null stream) (multiple-value-bind (words bytes) - (truncate alignment sb!vm:n-word-bytes) - (when (> words 0) - (print-words words stream dstate)) - (when (> bytes 0) - (print-inst bytes stream dstate))) + (truncate alignment sb!vm:n-word-bytes) + (when (> words 0) + (print-words words stream dstate)) + (when (> bytes 0) + (print-inst bytes stream dstate))) (print-bytes alignment stream dstate)) (incf (dstate-next-offs dstate) alignment))) @@ -493,78 +493,78 @@ ;;; each instruction, with arguments of CHUNK, STREAM, and DSTATE. (defun map-segment-instructions (function segment dstate &optional stream) (declare (type function function) - (type segment segment) - (type disassem-state dstate) - (type (or null stream) stream)) + (type segment segment) + (type disassem-state dstate) + (type (or null stream) stream)) (let ((ispace (get-inst-space)) - (prefix-p nil)) ; just processed a prefix inst + (prefix-p nil)) ; just processed a prefix inst (rewind-current-segment dstate segment) (loop (when (>= (dstate-cur-offs dstate) - (seg-length (dstate-segment dstate))) - ;; done! - (return)) + (seg-length (dstate-segment dstate))) + ;; done! + (return)) (setf (dstate-next-offs dstate) (dstate-cur-offs dstate)) (call-offs-hooks t stream dstate) (unless (or prefix-p (null stream)) - (print-current-address stream dstate)) + (print-current-address stream dstate)) (call-offs-hooks nil stream dstate) (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) - (sb!sys:without-gcing - (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment))) - - (let ((chunk - (sap-ref-dchunk (dstate-segment-sap dstate) - (dstate-cur-offs dstate) - (dstate-byte-order dstate)))) - (let ((fun-prefix-p (call-fun-hooks chunk stream dstate))) - (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) - (setf prefix-p fun-prefix-p) - (let ((inst (find-inst chunk ispace))) - (cond ((null inst) - (handle-bogus-instruction stream dstate)) - (t + (sb!sys:without-gcing + (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment))) + + (let ((chunk + (sap-ref-dchunk (dstate-segment-sap dstate) + (dstate-cur-offs dstate) + (dstate-byte-order dstate)))) + (let ((fun-prefix-p (call-fun-hooks chunk stream dstate))) + (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) + (setf prefix-p fun-prefix-p) + (let ((inst (find-inst chunk ispace))) + (cond ((null inst) + (handle-bogus-instruction stream dstate)) + (t (setf (dstate-inst-properties dstate) nil) - (setf (dstate-next-offs dstate) - (+ (dstate-cur-offs dstate) - (inst-length inst))) - (let ((orig-next (dstate-next-offs dstate))) - (print-inst (inst-length inst) stream dstate :trailing-space nil) - (let ((prefilter (inst-prefilter inst)) - (control (inst-control inst))) - (when prefilter - (funcall prefilter chunk dstate)) - - ;; print any instruction bytes recognized by the prefilter which calls read-suffix - ;; and updates next-offs - (when stream - (let ((suffix-len (- (dstate-next-offs dstate) orig-next))) - (when (plusp suffix-len) - (print-inst suffix-len stream dstate :offset (inst-length inst) :trailing-space nil)) - (dotimes (i (- *disassem-inst-column-width* (* 2 (+ (inst-length inst) suffix-len)))) - (write-char #\space stream))) - (write-char #\space stream)) - - (funcall function chunk inst) - - (setf prefix-p (null (inst-printer inst))) - - (when control - (funcall control chunk inst stream dstate)) - )))))))))) - + (setf (dstate-next-offs dstate) + (+ (dstate-cur-offs dstate) + (inst-length inst))) + (let ((orig-next (dstate-next-offs dstate))) + (print-inst (inst-length inst) stream dstate :trailing-space nil) + (let ((prefilter (inst-prefilter inst)) + (control (inst-control inst))) + (when prefilter + (funcall prefilter chunk dstate)) + + ;; print any instruction bytes recognized by the prefilter which calls read-suffix + ;; and updates next-offs + (when stream + (let ((suffix-len (- (dstate-next-offs dstate) orig-next))) + (when (plusp suffix-len) + (print-inst suffix-len stream dstate :offset (inst-length inst) :trailing-space nil)) + (dotimes (i (- *disassem-inst-column-width* (* 2 (+ (inst-length inst) suffix-len)))) + (write-char #\space stream))) + (write-char #\space stream)) + + (funcall function chunk inst) + + (setf prefix-p (null (inst-printer inst))) + + (when control + (funcall control chunk inst stream dstate)) + )))))))))) + (setf (dstate-cur-offs dstate) (dstate-next-offs dstate)) - + (unless (null stream) - (unless prefix-p - (print-notes-and-newline stream dstate)) - (setf (dstate-output-state dstate) nil))))) + (unless prefix-p + (print-notes-and-newline stream dstate)) + (setf (dstate-output-state dstate) nil))))) ;;; Make an initial non-printing disassembly pass through DSTATE, ;;; noting any addresses that are referenced by instructions in this @@ -578,8 +578,8 @@ (lambda (chunk inst) (declare (type dchunk chunk) (type instruction inst)) (let ((labeller (inst-labeller inst))) - (when labeller - (setf labels (funcall labeller chunk labels dstate))))) + (when labeller + (setf labels (funcall labeller chunk labels dstate))))) segment dstate) (setf (dstate-labels dstate) labels) @@ -595,16 +595,16 @@ ;; at least one label left un-numbered (setf labels (sort labels #'< :key #'car)) (let ((max -1) - (label-hash (dstate-label-hash dstate))) - (dolist (label labels) - (when (not (null (cdr label))) - (setf max (max max (cdr label))))) - (dolist (label labels) - (when (null (cdr label)) - (incf max) - (setf (cdr label) max) - (setf (gethash (car label) label-hash) - (format nil "L~W" max))))) + (label-hash (dstate-label-hash dstate))) + (dolist (label labels) + (when (not (null (cdr label))) + (setf max (max max (cdr label))))) + (dolist (label labels) + (when (null (cdr label)) + (incf max) + (setf (cdr label) max) + (setf (gethash (car label) label-hash) + (format nil "L~W" max))))) (setf (dstate-labels dstate) labels)))) ;;; Get the instruction-space, creating it if necessary. @@ -612,12 +612,12 @@ (let ((ispace *disassem-inst-space*)) (when (null ispace) (let ((insts nil)) - (maphash (lambda (name inst-flavs) - (declare (ignore name)) - (dolist (flav inst-flavs) - (push flav insts))) - *disassem-insts*) - (setf ispace (build-inst-space insts))) + (maphash (lambda (name inst-flavs) + (declare (ignore name)) + (dolist (flav inst-flavs) + (push flav insts))) + *disassem-insts*) + (setf ispace (build-inst-space insts))) (setf *disassem-inst-space* ispace)) ispace)) @@ -626,58 +626,58 @@ (defun add-offs-hook (segment addr hook) (let ((entry (cons addr hook))) (if (null (seg-hooks segment)) - (setf (seg-hooks segment) (list entry)) - (push entry (cdr (last (seg-hooks segment))))))) + (setf (seg-hooks segment) (list entry)) + (push entry (cdr (last (seg-hooks segment))))))) (defun add-offs-note-hook (segment addr note) (add-offs-hook segment - addr - (lambda (stream dstate) - (declare (type (or null stream) stream) - (type disassem-state dstate)) - (when stream - (note note dstate))))) + addr + (lambda (stream dstate) + (declare (type (or null stream) stream) + (type disassem-state dstate)) + (when stream + (note note dstate))))) (defun add-offs-comment-hook (segment addr comment) (add-offs-hook segment - addr - (lambda (stream dstate) - (declare (type (or null stream) stream) - (ignore dstate)) - (when stream - (write-string ";;; " stream) - (etypecase comment - (string - (write-string comment stream)) - (function - (funcall comment stream))) - (terpri stream))))) + addr + (lambda (stream dstate) + (declare (type (or null stream) stream) + (ignore dstate)) + (when stream + (write-string ";;; " stream) + (etypecase comment + (string + (write-string comment stream)) + (function + (funcall comment stream))) + (terpri stream))))) (defun add-fun-hook (dstate function) (push function (dstate-fun-hooks dstate))) (defun set-location-printing-range (dstate from length) (setf (dstate-addr-print-len dstate) - ;; 4 bits per hex digit - (ceiling (integer-length (logxor from (+ from length))) 4))) + ;; 4 bits per hex digit + (ceiling (integer-length (logxor from (+ from length))) 4))) ;;; Print the current address in DSTATE to STREAM, plus any labels that ;;; correspond to it, and leave the cursor in the instruction column. (defun print-current-address (stream dstate) (declare (type stream stream) - (type disassem-state dstate)) + (type disassem-state dstate)) (let* ((location - (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate))) - (location-column-width *disassem-location-column-width*) - (plen (dstate-addr-print-len dstate))) + (+ (seg-virtual-location (dstate-segment dstate)) + (dstate-cur-offs dstate))) + (location-column-width *disassem-location-column-width*) + (plen (dstate-addr-print-len dstate))) (when (null plen) (setf plen location-column-width) (let ((seg (dstate-segment dstate))) - (set-location-printing-range dstate - (seg-virtual-location seg) - (seg-length seg)))) + (set-location-printing-range dstate + (seg-virtual-location seg) + (seg-length seg)))) (when (eq (dstate-output-state dstate) :beginning) (setf plen location-column-width)) @@ -691,24 +691,24 @@ ;; usually avoids any consing] (tab0 (- location-column-width plen) stream) (let* ((printed-bits (* 4 plen)) - (printed-value (ldb (byte printed-bits 0) location)) - (leading-zeros - (truncate (- printed-bits (integer-length printed-value)) 4))) + (printed-value (ldb (byte printed-bits 0) location)) + (leading-zeros + (truncate (- printed-bits (integer-length printed-value)) 4))) (dotimes (i leading-zeros) - (write-char #\0 stream)) + (write-char #\0 stream)) (unless (zerop printed-value) - (write printed-value :stream stream :base 16 :radix nil)) + (write printed-value :stream stream :base 16 :radix nil)) (write-char #\: stream)) ;; print any labels (loop (let* ((next-label (car (dstate-cur-labels dstate))) - (label-location (car next-label))) - (when (or (null label-location) (> label-location location)) - (return)) - (unless (< label-location location) - (format stream " L~W:" (cdr next-label))) - (pop (dstate-cur-labels dstate)))) + (label-location (car next-label))) + (when (or (null label-location) (> label-location location)) + (return)) + (unless (< label-location location) + (format stream " L~W:" (cdr next-label))) + (pop (dstate-cur-labels dstate)))) ;; move to the instruction column (tab0 (+ location-column-width 1 label-column-width) stream) @@ -717,9 +717,9 @@ (eval-when (:compile-toplevel :execute) (sb!xc:defmacro with-print-restrictions (&rest body) `(let ((*print-pretty* t) - (*print-lines* 2) - (*print-length* 4) - (*print-level* 3)) + (*print-lines* 2) + (*print-length* 4) + (*print-level* 3)) ,@body))) ;;; Print a newline to STREAM, inserting any pending notes in DSTATE @@ -727,16 +727,16 @@ ;;; separate line will be used for each one. (defun print-notes-and-newline (stream dstate) (declare (type stream stream) - (type disassem-state dstate)) + (type disassem-state dstate)) (with-print-restrictions (dolist (note (dstate-notes dstate)) (format stream "~Vt " *disassem-note-column*) (pprint-logical-block (stream nil :per-line-prefix "; ") (etypecase note - (string - (write-string note stream)) - (function - (funcall note stream)))) + (string + (write-string note stream)) + (function + (funcall note stream)))) (terpri stream)) (fresh-line stream) (setf (dstate-notes dstate) nil))) @@ -744,87 +744,87 @@ ;;; Print NUM instruction bytes to STREAM as hex values. (defun print-inst (num stream dstate &key (offset 0) (trailing-space t)) (let ((sap (dstate-segment-sap dstate)) - (start-offs (+ offset (dstate-cur-offs dstate)))) + (start-offs (+ offset (dstate-cur-offs dstate)))) (dotimes (offs num) (format stream "~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs)))) (when trailing-space (dotimes (i (- *disassem-inst-column-width* (* 2 num))) - (write-char #\space stream)) + (write-char #\space stream)) (write-char #\space stream)))) ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions. (defun print-bytes (num stream dstate) (declare (type offset num) - (type stream stream) - (type disassem-state dstate)) + (type stream stream) + (type disassem-state dstate)) (format stream "~A~Vt" 'BYTE (dstate-argument-column dstate)) (let ((sap (dstate-segment-sap dstate)) - (start-offs (dstate-cur-offs dstate))) + (start-offs (dstate-cur-offs dstate))) (dotimes (offs num) (unless (zerop offs) - (write-string ", " stream)) + (write-string ", " stream)) (format stream "#X~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs)))))) ;;; Disassemble NUM machine-words to STREAM as simple `WORD' instructions. (defun print-words (num stream dstate) (declare (type offset num) - (type stream stream) - (type disassem-state dstate)) + (type stream stream) + (type disassem-state dstate)) (format stream "~A~Vt" 'WORD (dstate-argument-column dstate)) (let ((sap (dstate-segment-sap dstate)) - (start-offs (dstate-cur-offs dstate)) - (byte-order (dstate-byte-order dstate))) + (start-offs (dstate-cur-offs dstate)) + (byte-order (dstate-byte-order dstate))) (dotimes (word-offs num) (unless (zerop word-offs) - (write-string ", " stream)) + (write-string ", " stream)) (let ((word 0) (bit-shift 0)) - (dotimes (byte-offs sb!vm:n-word-bytes) - (let ((byte - (sb!sys:sap-ref-8 - sap - (+ start-offs - (* word-offs sb!vm:n-word-bytes) - byte-offs)))) - (setf word - (if (eq byte-order :big-endian) - (+ (ash word sb!vm:n-byte-bits) byte) - (+ word (ash byte bit-shift)))) - (incf bit-shift sb!vm:n-byte-bits))) - (format stream "#X~V,'0X" (ash sb!vm:n-word-bits -2) word))))) + (dotimes (byte-offs sb!vm:n-word-bytes) + (let ((byte + (sb!sys:sap-ref-8 + sap + (+ start-offs + (* word-offs sb!vm:n-word-bytes) + byte-offs)))) + (setf word + (if (eq byte-order :big-endian) + (+ (ash word sb!vm:n-byte-bits) byte) + (+ word (ash byte bit-shift)))) + (incf bit-shift sb!vm:n-byte-bits))) + (format stream "#X~V,'0X" (ash sb!vm:n-word-bits -2) word))))) (defvar *default-dstate-hooks* (list #'lra-hook)) ;;; Make a disassembler-state object. (defun make-dstate (&optional (fun-hooks *default-dstate-hooks*)) (let ((sap - (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8))))) - (alignment *disassem-inst-alignment-bytes*) - (arg-column - (+ (or *disassem-opcode-column-width* 0) - *disassem-location-column-width* - 1 - label-column-width))) + (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8))))) + (alignment *disassem-inst-alignment-bytes*) + (arg-column + (+ (or *disassem-opcode-column-width* 0) + *disassem-location-column-width* + 1 + label-column-width))) (when (> alignment 1) (push #'alignment-hook fun-hooks)) (%make-dstate :segment-sap sap - :fun-hooks fun-hooks - :argument-column arg-column - :alignment alignment - :byte-order sb!c:*backend-byte-order*))) + :fun-hooks fun-hooks + :argument-column arg-column + :alignment alignment + :byte-order sb!c:*backend-byte-order*))) (defun add-fun-header-hooks (segment) (declare (type segment segment)) (do ((fun (sb!kernel:code-header-ref (seg-code segment) - sb!vm:code-entry-points-slot) - (fun-next fun)) + sb!vm:code-entry-points-slot) + (fun-next fun)) (length (seg-length segment))) ((null fun)) (let ((offset (code-offs-to-segment-offs (fun-offset fun) segment))) (when (<= 0 offset length) - (push (make-offs-hook :offset offset :fun #'fun-header-hook) - (seg-hooks segment)))))) + (push (make-offs-hook :offset offset :fun #'fun-header-hook) + (seg-hooks segment)))))) ;;; A SAP-MAKER is a no-argument function that returns a SAP. @@ -832,34 +832,34 @@ (defun sap-maker (function input offset) (declare (optimize (speed 3)) - (type (function (t) sb!sys:system-area-pointer) function) - (type offset offset)) + (type (function (t) sb!sys:system-area-pointer) function) + (type offset offset)) (let ((old-sap (sb!sys:sap+ (funcall function input) offset))) (declare (type sb!sys:system-area-pointer old-sap)) (lambda () (let ((new-addr - (+ (sb!sys:sap-int (funcall function input)) offset))) - ;; Saving the sap like this avoids consing except when the sap - ;; changes (because the sap-int, arith, etc., get inlined). - (declare (type address new-addr)) - (if (= (sb!sys:sap-int old-sap) new-addr) - old-sap - (setf old-sap (sb!sys:int-sap new-addr))))))) + (+ (sb!sys:sap-int (funcall function input)) offset))) + ;; Saving the sap like this avoids consing except when the sap + ;; changes (because the sap-int, arith, etc., get inlined). + (declare (type address new-addr)) + (if (= (sb!sys:sap-int old-sap) new-addr) + old-sap + (setf old-sap (sb!sys:int-sap new-addr))))))) (defun vector-sap-maker (vector offset) (declare (optimize (speed 3)) - (type offset offset)) + (type offset offset)) (sap-maker #'sb!sys:vector-sap vector offset)) (defun code-sap-maker (code offset) (declare (optimize (speed 3)) - (type sb!kernel:code-component code) - (type offset offset)) + (type sb!kernel:code-component code) + (type offset offset)) (sap-maker #'sb!kernel:code-instructions code offset)) (defun memory-sap-maker (address) (declare (optimize (speed 3)) - (type address address)) + (type address address)) (let ((sap (sb!sys:int-sap address))) (lambda () sap))) @@ -871,75 +871,75 @@ ;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK ;;; objects). (defun make-segment (sap-maker length - &key - code virtual-location - debug-fun source-form-cache - hooks) + &key + code virtual-location + debug-fun source-form-cache + hooks) (declare (type (function () sb!sys:system-area-pointer) sap-maker) - (type disassem-length length) - (type (or null address) virtual-location) - (type (or null sb!di:debug-fun) debug-fun) - (type (or null source-form-cache) source-form-cache)) + (type disassem-length length) + (type (or null address) virtual-location) + (type (or null sb!di:debug-fun) debug-fun) + (type (or null source-form-cache) source-form-cache)) (let* ((segment - (%make-segment - :sap-maker sap-maker - :length length - :virtual-location (or virtual-location - (sb!sys:sap-int (funcall sap-maker))) - :hooks hooks - :code code))) + (%make-segment + :sap-maker sap-maker + :length length + :virtual-location (or virtual-location + (sb!sys:sap-int (funcall sap-maker))) + :hooks hooks + :code code))) (add-debugging-hooks segment debug-fun source-form-cache) (add-fun-header-hooks segment) segment)) (defun make-vector-segment (vector offset &rest args) (declare (type vector vector) - (type offset offset) - (inline make-segment)) + (type offset offset) + (inline make-segment)) (apply #'make-segment (vector-sap-maker vector offset) args)) (defun make-code-segment (code offset length &rest args) (declare (type sb!kernel:code-component code) - (type offset offset) - (inline make-segment)) + (type offset offset) + (inline make-segment)) (apply #'make-segment (code-sap-maker code offset) length :code code args)) (defun make-memory-segment (address &rest args) (declare (type address address) - (inline make-segment)) + (inline make-segment)) (apply #'make-segment (memory-sap-maker address) args)) ;;; just for fun (defun print-fun-headers (function) (declare (type compiled-function function)) (let* ((self (fun-self function)) - (code (sb!kernel:fun-code-header self))) + (code (sb!kernel:fun-code-header self))) (format t "Code-header ~S: size: ~S, trace-table-offset: ~S~%" - code - (sb!kernel:code-header-ref code - sb!vm:code-code-size-slot) - (sb!kernel:code-header-ref code - sb!vm:code-trace-table-offset-slot)) + code + (sb!kernel:code-header-ref code + sb!vm:code-code-size-slot) + (sb!kernel:code-header-ref code + sb!vm:code-trace-table-offset-slot)) (do ((fun (sb!kernel:code-header-ref code sb!vm:code-entry-points-slot) - (fun-next fun))) - ((null fun)) + (fun-next fun))) + ((null fun)) (let ((fun-offset (sb!kernel:get-closure-length fun))) - ;; There is function header fun-offset words from the - ;; code header. - (format t "Fun-header ~S at offset ~W (words): ~S~A => ~S~%" - fun - fun-offset - (sb!kernel:code-header-ref - code (+ fun-offset sb!vm:simple-fun-name-slot)) - (sb!kernel:code-header-ref - code (+ fun-offset sb!vm:simple-fun-arglist-slot)) - (sb!kernel:code-header-ref - code (+ fun-offset sb!vm:simple-fun-type-slot))))))) + ;; There is function header fun-offset words from the + ;; code header. + (format t "Fun-header ~S at offset ~W (words): ~S~A => ~S~%" + fun + fun-offset + (sb!kernel:code-header-ref + code (+ fun-offset sb!vm:simple-fun-name-slot)) + (sb!kernel:code-header-ref + code (+ fun-offset sb!vm:simple-fun-arglist-slot)) + (sb!kernel:code-header-ref + code (+ fun-offset sb!vm:simple-fun-type-slot))))))) ;;; getting at the source code... (defstruct (source-form-cache (:conc-name sfcache-) - (:copier nil)) + (:copier nil)) (debug-source nil :type (or null sb!di:debug-source)) (toplevel-form-index -1 :type fixnum) (toplevel-form nil :type list) @@ -952,94 +952,94 @@ (ecase (sb!di:debug-source-from debug-source) (:file (cond ((not (probe-file name)) - (warn "The source file ~S no longer seems to exist." name) - nil) - (t - (let ((start-positions - (sb!di:debug-source-start-positions debug-source))) - (cond ((null start-positions) - (warn "There is no start positions map.") - nil) - (t - (let* ((local-tlf-index - (- tlf-index - (sb!di:debug-source-root-number - debug-source))) - (char-offset - (aref start-positions local-tlf-index))) - (with-open-file (f name) - (cond ((= (sb!di:debug-source-created debug-source) - (file-write-date name)) - (file-position f char-offset)) - (t - (warn "Source file ~S has been modified; ~@ + (warn "The source file ~S no longer seems to exist." name) + nil) + (t + (let ((start-positions + (sb!di:debug-source-start-positions debug-source))) + (cond ((null start-positions) + (warn "There is no start positions map.") + nil) + (t + (let* ((local-tlf-index + (- tlf-index + (sb!di:debug-source-root-number + debug-source))) + (char-offset + (aref start-positions local-tlf-index))) + (with-open-file (f name) + (cond ((= (sb!di:debug-source-created debug-source) + (file-write-date name)) + (file-position f char-offset)) + (t + (warn "Source file ~S has been modified; ~@ using form offset instead of ~ file index." - name) - (let ((*read-suppress* t)) - (dotimes (i local-tlf-index) (read f))))) - (let ((*readtable* (copy-readtable))) - (set-dispatch-macro-character - #\# #\. - (lambda (stream sub-char &rest rest) - (declare (ignore rest sub-char)) - (let ((token (read stream t nil t))) - (format nil "#.~S" token)))) - (read f)) - )))))))) + name) + (let ((*read-suppress* t)) + (dotimes (i local-tlf-index) (read f))))) + (let ((*readtable* (copy-readtable))) + (set-dispatch-macro-character + #\# #\. + (lambda (stream sub-char &rest rest) + (declare (ignore rest sub-char)) + (let ((token (read stream t nil t))) + (format nil "#.~S" token)))) + (read f)) + )))))))) (:lisp (aref name tlf-index))))) (defun cache-valid (loc cache) (and cache (and (eq (sb!di:code-location-debug-source loc) - (sfcache-debug-source cache)) - (eq (sb!di:code-location-toplevel-form-offset loc) - (sfcache-toplevel-form-index cache))))) + (sfcache-debug-source cache)) + (eq (sb!di:code-location-toplevel-form-offset loc) + (sfcache-toplevel-form-index cache))))) (defun get-source-form (loc context &optional cache) (let* ((cache-valid (cache-valid loc cache)) - (tlf-index (sb!di:code-location-toplevel-form-offset loc)) - (form-number (sb!di:code-location-form-number loc)) - (toplevel-form - (if cache-valid - (sfcache-toplevel-form cache) - (get-toplevel-form (sb!di:code-location-debug-source loc) - tlf-index))) - (mapping-table - (if cache-valid - (sfcache-form-number-mapping-table cache) - (sb!di:form-number-translations toplevel-form tlf-index)))) + (tlf-index (sb!di:code-location-toplevel-form-offset loc)) + (form-number (sb!di:code-location-form-number loc)) + (toplevel-form + (if cache-valid + (sfcache-toplevel-form cache) + (get-toplevel-form (sb!di:code-location-debug-source loc) + tlf-index))) + (mapping-table + (if cache-valid + (sfcache-form-number-mapping-table cache) + (sb!di:form-number-translations toplevel-form tlf-index)))) (when (and (not cache-valid) cache) (setf (sfcache-debug-source cache) (sb!di:code-location-debug-source loc) - (sfcache-toplevel-form-index cache) tlf-index - (sfcache-toplevel-form cache) toplevel-form - (sfcache-form-number-mapping-table cache) mapping-table)) + (sfcache-toplevel-form-index cache) tlf-index + (sfcache-toplevel-form cache) toplevel-form + (sfcache-form-number-mapping-table cache) mapping-table)) (cond ((null toplevel-form) - nil) - ((> form-number (length mapping-table)) - (warn "bogus form-number in form! The source file has probably ~@ + nil) + ((> form-number (length mapping-table)) + (warn "bogus form-number in form! The source file has probably ~@ been changed too much to cope with.") - (when cache - ;; Disable future warnings. - (setf (sfcache-toplevel-form cache) nil)) - nil) - (t - (when cache - (setf (sfcache-last-location-retrieved cache) loc) - (setf (sfcache-last-form-retrieved cache) form-number)) - (sb!di:source-path-context toplevel-form - (aref mapping-table form-number) - context))))) + (when cache + ;; Disable future warnings. + (setf (sfcache-toplevel-form cache) nil)) + nil) + (t + (when cache + (setf (sfcache-last-location-retrieved cache) loc) + (setf (sfcache-last-form-retrieved cache) form-number)) + (sb!di:source-path-context toplevel-form + (aref mapping-table form-number) + context))))) (defun get-different-source-form (loc context &optional cache) (if (and (cache-valid loc cache) - (or (= (sb!di:code-location-form-number loc) - (sfcache-last-form-retrieved cache)) - (and (sfcache-last-location-retrieved cache) - (sb!di:code-location= - loc - (sfcache-last-location-retrieved cache))))) + (or (= (sb!di:code-location-form-number loc) + (sfcache-last-form-retrieved cache)) + (and (sfcache-last-location-retrieved cache) + (sb!di:code-location= + loc + (sfcache-last-location-retrieved cache))))) (values nil nil) (values (get-source-form loc context cache) t))) @@ -1053,7 +1053,7 @@ (locations #() :type (vector (or list fixnum)))) (defstruct (storage-info (:copier nil)) - (groups nil :type list) ; alist of (name . location-group) + (groups nil :type list) ; alist of (name . location-group) (debug-vars #() :type vector)) ;;; Return the vector of DEBUG-VARs currently associated with DSTATE. @@ -1067,55 +1067,55 @@ ;;; in the current debug-var vector. (defun find-valid-storage-location (offset lg-name dstate) (declare (type offset offset) - (type symbol lg-name) - (type disassem-state dstate)) + (type symbol lg-name) + (type disassem-state dstate)) (let* ((storage-info - (seg-storage-info (dstate-segment dstate))) - (location-group - (and storage-info - (cdr (assoc lg-name (storage-info-groups storage-info))))) - (currently-valid - (dstate-current-valid-locations dstate))) + (seg-storage-info (dstate-segment dstate))) + (location-group + (and storage-info + (cdr (assoc lg-name (storage-info-groups storage-info))))) + (currently-valid + (dstate-current-valid-locations dstate))) (and location-group - (not (null currently-valid)) - (let ((locations (location-group-locations location-group))) - (and (< offset (length locations)) - (let ((used-by (aref locations offset))) - (and used-by - (let ((debug-var-num - (typecase used-by - (fixnum - (and (not - (zerop (bit currently-valid used-by))) - used-by)) - (list - (some (lambda (num) - (and (not - (zerop - (bit currently-valid num))) - num)) - used-by))))) - (and debug-var-num - (progn - ;; Found a valid storage reference! - ;; can't use it again until it's revalidated... - (setf (bit (dstate-current-valid-locations - dstate) - debug-var-num) - 0) - debug-var-num)) - )))))))) + (not (null currently-valid)) + (let ((locations (location-group-locations location-group))) + (and (< offset (length locations)) + (let ((used-by (aref locations offset))) + (and used-by + (let ((debug-var-num + (typecase used-by + (fixnum + (and (not + (zerop (bit currently-valid used-by))) + used-by)) + (list + (some (lambda (num) + (and (not + (zerop + (bit currently-valid num))) + num)) + used-by))))) + (and debug-var-num + (progn + ;; Found a valid storage reference! + ;; can't use it again until it's revalidated... + (setf (bit (dstate-current-valid-locations + dstate) + debug-var-num) + 0) + debug-var-num)) + )))))))) ;;; Return a new vector which has the same contents as the old one ;;; VEC, plus new cells (for a total size of NEW-LEN). The additional ;;; elements are initialized to INITIAL-ELEMENT. (defun grow-vector (vec new-len &optional initial-element) (declare (type vector vec) - (type fixnum new-len)) + (type fixnum new-len)) (let ((new - (make-sequence `(vector ,(array-element-type vec) ,new-len) - new-len - :initial-element initial-element))) + (make-sequence `(vector ,(array-element-type vec) ,new-len) + new-len + :initial-element initial-element))) (dotimes (i (length vec)) (setf (aref new i) (aref vec i))) new)) @@ -1125,70 +1125,70 @@ (defun storage-info-for-debug-fun (debug-fun) (declare (type sb!di:debug-fun debug-fun)) (let ((sc-vec sb!c::*backend-sc-numbers*) - (groups nil) - (debug-vars (sb!di::debug-fun-debug-vars - debug-fun))) + (groups nil) + (debug-vars (sb!di::debug-fun-debug-vars + debug-fun))) (and debug-vars - (dotimes (debug-var-offset - (length debug-vars) - (make-storage-info :groups groups - :debug-vars debug-vars)) - (let ((debug-var (aref debug-vars debug-var-offset))) - #+nil - (format t ";;; At offset ~W: ~S~%" debug-var-offset debug-var) - (let* ((sc-offset - (sb!di::compiled-debug-var-sc-offset debug-var)) - (sb-name - (sb!c:sb-name - (sb!c:sc-sb (aref sc-vec - (sb!c:sc-offset-scn sc-offset)))))) - #+nil - (format t ";;; SET: ~S[~W]~%" - sb-name (sb!c:sc-offset-offset sc-offset)) - (unless (null sb-name) - (let ((group (cdr (assoc sb-name groups)))) - (when (null group) - (setf group (make-location-group)) - (push `(,sb-name . ,group) groups)) - (let* ((locations (location-group-locations group)) - (length (length locations)) - (offset (sb!c:sc-offset-offset sc-offset))) - (when (>= offset length) - (setf locations - (grow-vector locations - (max (* 2 length) - (1+ offset)) - nil) - (location-group-locations group) - locations)) - (let ((already-there (aref locations offset))) - (cond ((null already-there) - (setf (aref locations offset) debug-var-offset)) - ((eql already-there debug-var-offset)) - (t - (if (listp already-there) - (pushnew debug-var-offset - (aref locations offset)) - (setf (aref locations offset) - (list debug-var-offset - already-there))))) - ))))))) - ))) + (dotimes (debug-var-offset + (length debug-vars) + (make-storage-info :groups groups + :debug-vars debug-vars)) + (let ((debug-var (aref debug-vars debug-var-offset))) + #+nil + (format t ";;; At offset ~W: ~S~%" debug-var-offset debug-var) + (let* ((sc-offset + (sb!di::compiled-debug-var-sc-offset debug-var)) + (sb-name + (sb!c:sb-name + (sb!c:sc-sb (aref sc-vec + (sb!c:sc-offset-scn sc-offset)))))) + #+nil + (format t ";;; SET: ~S[~W]~%" + sb-name (sb!c:sc-offset-offset sc-offset)) + (unless (null sb-name) + (let ((group (cdr (assoc sb-name groups)))) + (when (null group) + (setf group (make-location-group)) + (push `(,sb-name . ,group) groups)) + (let* ((locations (location-group-locations group)) + (length (length locations)) + (offset (sb!c:sc-offset-offset sc-offset))) + (when (>= offset length) + (setf locations + (grow-vector locations + (max (* 2 length) + (1+ offset)) + nil) + (location-group-locations group) + locations)) + (let ((already-there (aref locations offset))) + (cond ((null already-there) + (setf (aref locations offset) debug-var-offset)) + ((eql already-there debug-var-offset)) + (t + (if (listp already-there) + (pushnew debug-var-offset + (aref locations offset)) + (setf (aref locations offset) + (list debug-var-offset + already-there))))) + ))))))) + ))) (defun source-available-p (debug-fun) (handler-case (sb!di:do-debug-fun-blocks (block debug-fun) - (declare (ignore block)) - (return t)) + (declare (ignore block)) + (return t)) (sb!di:no-debug-blocks () nil))) (defun print-block-boundary (stream dstate) (let ((os (dstate-output-state dstate))) (when (not (eq os :beginning)) (when (not (eq os :block-boundary)) - (terpri stream)) + (terpri stream)) (setf (dstate-output-state dstate) - :block-boundary)))) + :block-boundary)))) ;;; Add hooks to track to track the source code in SEGMENT during ;;; disassembly. SFCACHE can be either NIL or it can be a @@ -1196,204 +1196,204 @@ ;;; forms from files. (defun add-source-tracking-hooks (segment debug-fun &optional sfcache) (declare (type segment segment) - (type (or null sb!di:debug-fun) debug-fun) - (type (or null source-form-cache) sfcache)) + (type (or null sb!di:debug-fun) debug-fun) + (type (or null source-form-cache) sfcache)) (let ((last-block-pc -1)) (flet ((add-hook (pc fun &optional before-address) - (push (make-offs-hook - :offset pc ;; ### FIX to account for non-zero offs in code - :fun fun - :before-address before-address) - (seg-hooks segment)))) + (push (make-offs-hook + :offset pc ;; ### FIX to account for non-zero offs in code + :fun fun + :before-address before-address) + (seg-hooks segment)))) (handler-case - (sb!di:do-debug-fun-blocks (block debug-fun) - (let ((first-location-in-block-p t)) - (sb!di:do-debug-block-locations (loc block) - (let ((pc (sb!di::compiled-code-location-pc loc))) - - ;; Put blank lines in at block boundaries - (when (and first-location-in-block-p - (/= pc last-block-pc)) - (setf first-location-in-block-p nil) - (add-hook pc - (lambda (stream dstate) - (print-block-boundary stream dstate)) - t) - (setf last-block-pc pc)) - - ;; Print out corresponding source; this information is not - ;; all that accurate, but it's better than nothing - (unless (zerop (sb!di:code-location-form-number loc)) - (multiple-value-bind (form new) - (get-different-source-form loc 0 sfcache) - (when new - (let ((at-block-begin (= pc last-block-pc))) - (add-hook - pc - (lambda (stream dstate) - (declare (ignore dstate)) - (when stream - (unless at-block-begin - (terpri stream)) - (format stream ";;; [~W] " - (sb!di:code-location-form-number - loc)) - (prin1-short form stream) - (terpri stream) - (terpri stream))) - t))))) - - ;; Keep track of variable live-ness as best we can. - (let ((live-set - (copy-seq (sb!di::compiled-code-location-live-set - loc)))) - (add-hook - pc - (lambda (stream dstate) - (declare (ignore stream)) - (setf (dstate-current-valid-locations dstate) - live-set) - #+nil - (note (lambda (stream) - (let ((*print-length* nil)) - (format stream "live set: ~S" - live-set))) - dstate)))) - )))) - (sb!di:no-debug-blocks () nil))))) + (sb!di:do-debug-fun-blocks (block debug-fun) + (let ((first-location-in-block-p t)) + (sb!di:do-debug-block-locations (loc block) + (let ((pc (sb!di::compiled-code-location-pc loc))) + + ;; Put blank lines in at block boundaries + (when (and first-location-in-block-p + (/= pc last-block-pc)) + (setf first-location-in-block-p nil) + (add-hook pc + (lambda (stream dstate) + (print-block-boundary stream dstate)) + t) + (setf last-block-pc pc)) + + ;; Print out corresponding source; this information is not + ;; all that accurate, but it's better than nothing + (unless (zerop (sb!di:code-location-form-number loc)) + (multiple-value-bind (form new) + (get-different-source-form loc 0 sfcache) + (when new + (let ((at-block-begin (= pc last-block-pc))) + (add-hook + pc + (lambda (stream dstate) + (declare (ignore dstate)) + (when stream + (unless at-block-begin + (terpri stream)) + (format stream ";;; [~W] " + (sb!di:code-location-form-number + loc)) + (prin1-short form stream) + (terpri stream) + (terpri stream))) + t))))) + + ;; Keep track of variable live-ness as best we can. + (let ((live-set + (copy-seq (sb!di::compiled-code-location-live-set + loc)))) + (add-hook + pc + (lambda (stream dstate) + (declare (ignore stream)) + (setf (dstate-current-valid-locations dstate) + live-set) + #+nil + (note (lambda (stream) + (let ((*print-length* nil)) + (format stream "live set: ~S" + live-set))) + dstate)))) + )))) + (sb!di:no-debug-blocks () nil))))) (defun add-debugging-hooks (segment debug-fun &optional sfcache) (when debug-fun (setf (seg-storage-info segment) - (storage-info-for-debug-fun debug-fun)) + (storage-info-for-debug-fun debug-fun)) (add-source-tracking-hooks segment debug-fun sfcache) (let ((kind (sb!di:debug-fun-kind debug-fun))) (flet ((add-new-hook (n) - (push (make-offs-hook - :offset 0 - :fun (lambda (stream dstate) - (declare (ignore stream)) - (note n dstate))) - (seg-hooks segment)))) - (case kind - (:external) - ((nil) - (add-new-hook "no-arg-parsing entry point")) - (t - (add-new-hook (lambda (stream) - (format stream "~S entry point" kind))))))))) + (push (make-offs-hook + :offset 0 + :fun (lambda (stream dstate) + (declare (ignore stream)) + (note n dstate))) + (seg-hooks segment)))) + (case kind + (:external) + ((nil) + (add-new-hook "no-arg-parsing entry point")) + (t + (add-new-hook (lambda (stream) + (format stream "~S entry point" kind))))))))) ;;; Return a list of the segments of memory containing machine code ;;; instructions for FUNCTION. (defun get-fun-segments (function) (declare (type compiled-function function)) (let* ((code (fun-code function)) - (fun-map (code-fun-map code)) - (fname (sb!kernel:%simple-fun-name function)) - (sfcache (make-source-form-cache))) + (fun-map (code-fun-map code)) + (fname (sb!kernel:%simple-fun-name function)) + (sfcache (make-source-form-cache))) (let ((first-block-seen-p nil) - (nil-block-seen-p nil) - (last-offset 0) - (last-debug-fun nil) - (segments nil)) + (nil-block-seen-p nil) + (last-offset 0) + (last-debug-fun nil) + (segments nil)) (flet ((add-seg (offs len df) - (when (> len 0) - (push (make-code-segment code offs len - :debug-fun df - :source-form-cache sfcache) - segments)))) - (dotimes (fmap-index (length fun-map)) - (let ((fmap-entry (aref fun-map fmap-index))) - (etypecase fmap-entry - (integer - (when first-block-seen-p - (add-seg last-offset - (- fmap-entry last-offset) - last-debug-fun) - (setf last-debug-fun nil)) - (setf last-offset fmap-entry)) - (sb!c::compiled-debug-fun - (let ((name (sb!c::compiled-debug-fun-name fmap-entry)) - (kind (sb!c::compiled-debug-fun-kind fmap-entry))) - #+nil - (format t ";;; SAW ~S ~S ~S,~S ~W,~W~%" - name kind first-block-seen-p nil-block-seen-p - last-offset - (sb!c::compiled-debug-fun-start-pc fmap-entry)) - (cond (#+nil (eq last-offset fun-offset) - (and (equal name fname) (not first-block-seen-p)) - (setf first-block-seen-p t)) - ((eq kind :external) - (when first-block-seen-p - (return))) - ((eq kind nil) - (when nil-block-seen-p - (return)) - (when first-block-seen-p - (setf nil-block-seen-p t)))) - (setf last-debug-fun - (sb!di::make-compiled-debug-fun fmap-entry code))))))) - (let ((max-offset (code-inst-area-length code))) - (when (and first-block-seen-p last-debug-fun) - (add-seg last-offset - (- max-offset last-offset) - last-debug-fun)) - (if (null segments) - (let ((offs (fun-insts-offset function))) - (list - (make-code-segment code offs (- max-offset offs)))) - (nreverse segments))))))) + (when (> len 0) + (push (make-code-segment code offs len + :debug-fun df + :source-form-cache sfcache) + segments)))) + (dotimes (fmap-index (length fun-map)) + (let ((fmap-entry (aref fun-map fmap-index))) + (etypecase fmap-entry + (integer + (when first-block-seen-p + (add-seg last-offset + (- fmap-entry last-offset) + last-debug-fun) + (setf last-debug-fun nil)) + (setf last-offset fmap-entry)) + (sb!c::compiled-debug-fun + (let ((name (sb!c::compiled-debug-fun-name fmap-entry)) + (kind (sb!c::compiled-debug-fun-kind fmap-entry))) + #+nil + (format t ";;; SAW ~S ~S ~S,~S ~W,~W~%" + name kind first-block-seen-p nil-block-seen-p + last-offset + (sb!c::compiled-debug-fun-start-pc fmap-entry)) + (cond (#+nil (eq last-offset fun-offset) + (and (equal name fname) (not first-block-seen-p)) + (setf first-block-seen-p t)) + ((eq kind :external) + (when first-block-seen-p + (return))) + ((eq kind nil) + (when nil-block-seen-p + (return)) + (when first-block-seen-p + (setf nil-block-seen-p t)))) + (setf last-debug-fun + (sb!di::make-compiled-debug-fun fmap-entry code))))))) + (let ((max-offset (code-inst-area-length code))) + (when (and first-block-seen-p last-debug-fun) + (add-seg last-offset + (- max-offset last-offset) + last-debug-fun)) + (if (null segments) + (let ((offs (fun-insts-offset function))) + (list + (make-code-segment code offs (- max-offset offs)))) + (nreverse segments))))))) ;;; Return a list of the segments of memory containing machine code ;;; instructions for the code-component CODE. If START-OFFSET and/or ;;; LENGTH is supplied, only that part of the code-segment is used ;;; (but these are constrained to lie within the code-segment). (defun get-code-segments (code - &optional - (start-offset 0) - (length (code-inst-area-length code))) + &optional + (start-offset 0) + (length (code-inst-area-length code))) (declare (type sb!kernel:code-component code) - (type offset start-offset) - (type disassem-length length)) + (type offset start-offset) + (type disassem-length length)) (let ((segments nil)) (when code (let ((fun-map (code-fun-map code)) - (sfcache (make-source-form-cache))) - (let ((last-offset 0) - (last-debug-fun nil)) - (flet ((add-seg (offs len df) - (let* ((restricted-offs - (min (max start-offset offs) - (+ start-offset length))) - (restricted-len - (- (min (max start-offset (+ offs len)) - (+ start-offset length)) - restricted-offs))) - (when (> restricted-len 0) - (push (make-code-segment code - restricted-offs restricted-len - :debug-fun df - :source-form-cache sfcache) - segments))))) - (dotimes (fun-map-index (length fun-map)) - (let ((fun-map-entry (aref fun-map fun-map-index))) - (etypecase fun-map-entry - (integer - (add-seg last-offset (- fun-map-entry last-offset) - last-debug-fun) - (setf last-debug-fun nil) - (setf last-offset fun-map-entry)) - (sb!c::compiled-debug-fun - (setf last-debug-fun - (sb!di::make-compiled-debug-fun fun-map-entry - code)))))) - (when last-debug-fun - (add-seg last-offset - (- (code-inst-area-length code) last-offset) - last-debug-fun)))))) + (sfcache (make-source-form-cache))) + (let ((last-offset 0) + (last-debug-fun nil)) + (flet ((add-seg (offs len df) + (let* ((restricted-offs + (min (max start-offset offs) + (+ start-offset length))) + (restricted-len + (- (min (max start-offset (+ offs len)) + (+ start-offset length)) + restricted-offs))) + (when (> restricted-len 0) + (push (make-code-segment code + restricted-offs restricted-len + :debug-fun df + :source-form-cache sfcache) + segments))))) + (dotimes (fun-map-index (length fun-map)) + (let ((fun-map-entry (aref fun-map fun-map-index))) + (etypecase fun-map-entry + (integer + (add-seg last-offset (- fun-map-entry last-offset) + last-debug-fun) + (setf last-debug-fun nil) + (setf last-offset fun-map-entry)) + (sb!c::compiled-debug-fun + (setf last-debug-fun + (sb!di::make-compiled-debug-fun fun-map-entry + code)))))) + (when last-debug-fun + (add-seg last-offset + (- (code-inst-area-length code) last-offset) + last-debug-fun)))))) (if (null segments) - (make-code-segment code start-offset length) - (nreverse segments)))) + (make-code-segment code start-offset length) + (nreverse segments)))) ;;; Return two values: the amount by which the last instruction in the ;;; segment goes past the end of the segment, and the offset of the @@ -1401,16 +1401,16 @@ ;;; instructions fit perfectly, return 0 and 0. (defun segment-overflow (segment dstate) (declare (type segment segment) - (type disassem-state dstate)) + (type disassem-state dstate)) (let ((seglen (seg-length segment)) - (last-start 0)) + (last-start 0)) (map-segment-instructions (lambda (chunk inst) - (declare (ignore chunk inst)) - (setf last-start (dstate-cur-offs dstate))) - segment - dstate) + (declare (ignore chunk inst)) + (setf last-start (dstate-cur-offs dstate))) + segment + dstate) (values (- (dstate-cur-offs dstate) seglen) - (- seglen last-start)))) + (- seglen last-start)))) ;;; Compute labels for all the memory segments in SEGLIST and adds ;;; them to DSTATE. It's important to call this function with all the @@ -1418,35 +1418,35 @@ ;;; one to another. (defun label-segments (seglist dstate) (declare (type list seglist) - (type disassem-state dstate)) + (type disassem-state dstate)) (dolist (seg seglist) (add-segment-labels seg dstate)) ;; Now remove any labels that don't point anywhere in the segments ;; we have. (setf (dstate-labels dstate) - (remove-if (lambda (lab) - (not - (some (lambda (seg) - (let ((start (seg-virtual-location seg))) - (<= start - (car lab) - (+ start (seg-length seg))))) - seglist))) - (dstate-labels dstate)))) + (remove-if (lambda (lab) + (not + (some (lambda (seg) + (let ((start (seg-virtual-location seg))) + (<= start + (car lab) + (+ start (seg-length seg))))) + seglist))) + (dstate-labels dstate)))) ;;; Disassemble the machine code instructions in SEGMENT to STREAM. (defun disassemble-segment (segment stream dstate) (declare (type segment segment) - (type stream stream) - (type disassem-state dstate)) + (type stream stream) + (type disassem-state dstate)) (let ((*print-pretty* nil)) ; otherwise the pp conses hugely (number-labels dstate) (map-segment-instructions (lambda (chunk inst) (declare (type dchunk chunk) (type instruction inst)) (let ((printer (inst-printer inst))) - (when printer - (funcall printer chunk inst stream dstate)))) + (when printer + (funcall printer chunk inst stream dstate)))) segment dstate stream))) @@ -1455,31 +1455,31 @@ ;;; in SEGMENTS in turn to STREAM. (defun disassemble-segments (segments stream dstate) (declare (type list segments) - (type stream stream) - (type disassem-state dstate)) + (type stream stream) + (type disassem-state dstate)) (unless (null segments) (let ((first (car segments)) - (last (car (last segments)))) + (last (car (last segments)))) (set-location-printing-range dstate - (seg-virtual-location first) - (- (+ (seg-virtual-location last) - (seg-length last)) - (seg-virtual-location first))) + (seg-virtual-location first) + (- (+ (seg-virtual-location last) + (seg-length last)) + (seg-virtual-location first))) (setf (dstate-output-state dstate) :beginning) (dolist (seg segments) - (disassemble-segment seg stream dstate))))) + (disassemble-segment seg stream dstate))))) ;;;; top level functions ;;; Disassemble the machine code instructions for FUNCTION. (defun disassemble-fun (fun &key - (stream *standard-output*) - (use-labels t)) + (stream *standard-output*) + (use-labels t)) (declare (type compiled-function fun) - (type stream stream) - (type (member t nil) use-labels)) + (type stream stream) + (type (member t nil) use-labels)) (let* ((dstate (make-dstate)) - (segments (get-fun-segments fun))) + (segments (get-fun-segments fun))) (when use-labels (label-segments segments dstate)) (disassemble-segments segments stream dstate))) @@ -1497,30 +1497,30 @@ (defun compiled-fun-or-lose (thing &optional (name thing)) (cond ((legal-fun-name-p thing) - (compiled-fun-or-lose (fdefinition thing) thing)) - ((functionp thing) - thing) - ((and (listp thing) - (eq (car thing) 'lambda)) - (compile nil thing)) - (t - (error "can't make a compiled function from ~S" name)))) + (compiled-fun-or-lose (fdefinition thing) thing)) + ((functionp thing) + thing) + ((and (listp thing) + (eq (car thing) 'lambda)) + (compile nil thing)) + (t + (error "can't make a compiled function from ~S" name)))) (defun disassemble (object &key - (stream *standard-output*) - (use-labels t)) + (stream *standard-output*) + (use-labels t)) #!+sb-doc "Disassemble the compiled code associated with OBJECT, which can be a function, a lambda expression, or a symbol with a function definition. If it is not already compiled, the compiler is called to produce something to disassemble." (declare (type (or function symbol cons) object) - (type (or (member t) stream) stream) - (type (member t nil) use-labels)) + (type (or (member t) stream) stream) + (type (member t nil) use-labels)) (pprint-logical-block (*standard-output* nil :per-line-prefix "; ") (disassemble-fun (compiled-fun-or-lose object) - :stream stream - :use-labels use-labels) + :stream stream + :use-labels use-labels) nil)) ;;; Disassembles the given area of memory starting at ADDRESS and @@ -1528,33 +1528,33 @@ ;;; could move during a GC, you'd better disable it around the call to ;;; this function. (defun disassemble-memory (address - length - &key - (stream *standard-output*) - code-component - (use-labels t)) + length + &key + (stream *standard-output*) + code-component + (use-labels t)) (declare (type (or address sb!sys:system-area-pointer) address) - (type disassem-length length) - (type stream stream) - (type (or null sb!kernel:code-component) code-component) - (type (member t nil) use-labels)) - (let* ((address - (if (sb!sys:system-area-pointer-p address) - (sb!sys:sap-int address) - address)) - (dstate (make-dstate)) - (segments - (if code-component - (let ((code-offs - (- address - (sb!sys:sap-int - (sb!kernel:code-instructions code-component))))) - (when (or (< code-offs 0) - (> code-offs (code-inst-area-length code-component))) - (error "address ~X not in the code component ~S" - address code-component)) - (get-code-segments code-component code-offs length)) - (list (make-memory-segment address length))))) + (type disassem-length length) + (type stream stream) + (type (or null sb!kernel:code-component) code-component) + (type (member t nil) use-labels)) + (let* ((address + (if (sb!sys:system-area-pointer-p address) + (sb!sys:sap-int address) + address)) + (dstate (make-dstate)) + (segments + (if code-component + (let ((code-offs + (- address + (sb!sys:sap-int + (sb!kernel:code-instructions code-component))))) + (when (or (< code-offs 0) + (> code-offs (code-inst-area-length code-component))) + (error "address ~X not in the code component ~S" + address code-component)) + (get-code-segments code-component code-offs length)) + (list (make-memory-segment address length))))) (when use-labels (label-segments segments dstate)) (disassemble-segments segments stream dstate))) @@ -1562,18 +1562,18 @@ ;;; Disassemble the machine code instructions associated with ;;; CODE-COMPONENT (this may include multiple entry points). (defun disassemble-code-component (code-component &key - (stream *standard-output*) - (use-labels t)) + (stream *standard-output*) + (use-labels t)) (declare (type (or null sb!kernel:code-component compiled-function) - code-component) - (type stream stream) - (type (member t nil) use-labels)) - (let* ((code-component - (if (functionp code-component) - (fun-code code-component) - code-component)) - (dstate (make-dstate)) - (segments (get-code-segments code-component))) + code-component) + (type stream stream) + (type (member t nil) use-labels)) + (let* ((code-component + (if (functionp code-component) + (fun-code code-component) + code-component)) + (dstate (make-dstate)) + (segments (get-code-segments code-component))) (when use-labels (label-segments segments dstate)) (disassemble-segments segments stream dstate))) @@ -1587,114 +1587,114 @@ (defconstant max-instruction-size 16) (defun add-block-segments (seg-code-block - seglist - location - connecting-vec - dstate) + seglist + location + connecting-vec + dstate) (declare (type list seglist) - (type integer location) - (type (or null (vector (unsigned-byte 8))) connecting-vec) - (type disassem-state dstate)) + (type integer location) + (type (or null (vector (unsigned-byte 8))) connecting-vec) + (type disassem-state dstate)) (flet ((addit (seg overflow) - (let ((length (+ (seg-length seg) overflow))) - (when (> length 0) - (setf (seg-length seg) length) - (incf location length) - (push seg seglist))))) + (let ((length (+ (seg-length seg) overflow))) + (when (> length 0) + (setf (seg-length seg) length) + (incf location length) + (push seg seglist))))) (let ((connecting-overflow 0) - (amount (length seg-code-block))) + (amount (length seg-code-block))) (when connecting-vec - ;; Tack on some of the new block to the old overflow vector. - (let* ((beginning-of-block-amount - (if seg-code-block (min max-instruction-size amount) 0)) - (connecting-vec - (if seg-code-block - (concatenate - '(vector (unsigned-byte 8)) - connecting-vec - (subseq seg-code-block 0 beginning-of-block-amount)) - connecting-vec))) - (when (and (< (length connecting-vec) max-instruction-size) - (not (null seg-code-block))) - (return-from add-block-segments - ;; We want connecting vectors to be large enough to hold - ;; any instruction, and since the current seg-code-block - ;; wasn't large enough to do this (and is now entirely - ;; on the end of the overflow-vector), just save it for - ;; next time. - (values seglist location connecting-vec))) - (when (> (length connecting-vec) 0) - (let ((seg - (make-vector-segment connecting-vec - 0 - (- (length connecting-vec) - beginning-of-block-amount) - :virtual-location location))) - (setf connecting-overflow (segment-overflow seg dstate)) - (addit seg connecting-overflow))))) + ;; Tack on some of the new block to the old overflow vector. + (let* ((beginning-of-block-amount + (if seg-code-block (min max-instruction-size amount) 0)) + (connecting-vec + (if seg-code-block + (concatenate + '(vector (unsigned-byte 8)) + connecting-vec + (subseq seg-code-block 0 beginning-of-block-amount)) + connecting-vec))) + (when (and (< (length connecting-vec) max-instruction-size) + (not (null seg-code-block))) + (return-from add-block-segments + ;; We want connecting vectors to be large enough to hold + ;; any instruction, and since the current seg-code-block + ;; wasn't large enough to do this (and is now entirely + ;; on the end of the overflow-vector), just save it for + ;; next time. + (values seglist location connecting-vec))) + (when (> (length connecting-vec) 0) + (let ((seg + (make-vector-segment connecting-vec + 0 + (- (length connecting-vec) + beginning-of-block-amount) + :virtual-location location))) + (setf connecting-overflow (segment-overflow seg dstate)) + (addit seg connecting-overflow))))) (cond ((null seg-code-block) - ;; nothing more to add - (values seglist location nil)) - ((< (- amount connecting-overflow) max-instruction-size) - ;; We can't create a segment with the minimum size - ;; required for an instruction, so just keep on accumulating - ;; in the overflow vector for the time-being. - (values seglist - location - (subseq seg-code-block connecting-overflow amount))) - (t - ;; Put as much as we can into a new segment, and the rest - ;; into the overflow-vector. - (let* ((initial-length - (- amount connecting-overflow max-instruction-size)) - (seg - (make-vector-segment seg-code-block - connecting-overflow - initial-length - :virtual-location location)) - (overflow - (segment-overflow seg dstate))) - (addit seg overflow) - (values seglist - location - (subseq seg-code-block - (+ connecting-overflow (seg-length seg)) - amount)))))))) + ;; nothing more to add + (values seglist location nil)) + ((< (- amount connecting-overflow) max-instruction-size) + ;; We can't create a segment with the minimum size + ;; required for an instruction, so just keep on accumulating + ;; in the overflow vector for the time-being. + (values seglist + location + (subseq seg-code-block connecting-overflow amount))) + (t + ;; Put as much as we can into a new segment, and the rest + ;; into the overflow-vector. + (let* ((initial-length + (- amount connecting-overflow max-instruction-size)) + (seg + (make-vector-segment seg-code-block + connecting-overflow + initial-length + :virtual-location location)) + (overflow + (segment-overflow seg dstate))) + (addit seg overflow) + (values seglist + location + (subseq seg-code-block + (+ connecting-overflow (seg-length seg)) + amount)))))))) ;;;; code to disassemble assembler segments (defun assem-segment-to-disassem-segments (assem-segment dstate) (declare (type sb!assem:segment assem-segment) - (type disassem-state dstate)) + (type disassem-state dstate)) (let ((location 0) - (disassem-segments nil) - (connecting-vec nil)) + (disassem-segments nil) + (connecting-vec nil)) (sb!assem:on-segment-contents-vectorly assem-segment (lambda (seg-code-block) (multiple-value-setq (disassem-segments location connecting-vec) (add-block-segments seg-code-block - disassem-segments - location - connecting-vec - dstate)))) + disassem-segments + location + connecting-vec + dstate)))) (when connecting-vec (setf disassem-segments - (add-block-segments nil - disassem-segments - location - connecting-vec - dstate))) + (add-block-segments nil + disassem-segments + location + connecting-vec + dstate))) (sort disassem-segments #'< :key #'seg-virtual-location))) ;;; Disassemble the machine code instructions associated with ;;; ASSEM-SEGMENT (of type assem:segment). (defun disassemble-assem-segment (assem-segment stream) (declare (type sb!assem:segment assem-segment) - (type stream stream)) + (type stream stream)) (let* ((dstate (make-dstate)) - (disassem-segments - (assem-segment-to-disassem-segments assem-segment dstate))) + (disassem-segments + (assem-segment-to-disassem-segments assem-segment dstate))) (label-segments disassem-segments dstate) (disassemble-segments disassem-segments stream dstate))) @@ -1704,11 +1704,11 @@ ;;; in a symbol object that we know about (defparameter *grokked-symbol-slots* (sort `((,sb!vm:symbol-value-slot . symbol-value) - (,sb!vm:symbol-plist-slot . symbol-plist) - (,sb!vm:symbol-name-slot . symbol-name) - (,sb!vm:symbol-package-slot . symbol-package)) - #'< - :key #'car)) + (,sb!vm:symbol-plist-slot . symbol-plist) + (,sb!vm:symbol-name-slot . symbol-name) + (,sb!vm:symbol-package-slot . symbol-package)) + #'< + :key #'car)) ;;; Given ADDRESS, try and figure out if which slot of which symbol is ;;; being referred to. Of course we can just give up, so it's not a @@ -1719,16 +1719,16 @@ (if (not (aligned-p address sb!vm:n-word-bytes)) (values nil nil) (do ((slots-tail *grokked-symbol-slots* (cdr slots-tail))) - ((null slots-tail) - (values nil nil)) - (let* ((field (car slots-tail)) - (slot-offset (words-to-bytes (car field))) - (maybe-symbol-addr (- address slot-offset)) - (maybe-symbol - (sb!kernel:make-lisp-obj - (+ maybe-symbol-addr sb!vm:other-pointer-lowtag)))) - (when (symbolp maybe-symbol) - (return (values maybe-symbol (cdr field)))))))) + ((null slots-tail) + (values nil nil)) + (let* ((field (car slots-tail)) + (slot-offset (words-to-bytes (car field))) + (maybe-symbol-addr (- address slot-offset)) + (maybe-symbol + (sb!kernel:make-lisp-obj + (+ maybe-symbol-addr sb!vm:other-pointer-lowtag)))) + (when (symbolp maybe-symbol) + (return (values maybe-symbol (cdr field)))))))) (defvar *address-of-nil-object* (sb!kernel:get-lisp-obj-address nil)) @@ -1751,16 +1751,16 @@ (defun get-code-constant (byte-offset dstate) #!+sb-doc (declare (type offset byte-offset) - (type disassem-state dstate)) + (type disassem-state dstate)) (let ((code (seg-code (dstate-segment dstate)))) (if code - (values - (sb!kernel:code-header-ref code - (ash (+ byte-offset - sb!vm:other-pointer-lowtag) - (- sb!vm:word-shift))) - t) - (values nil nil)))) + (values + (sb!kernel:code-header-ref code + (ash (+ byte-offset + sb!vm:other-pointer-lowtag) + (- sb!vm:word-shift))) + t) + (values nil nil)))) (defun get-code-constant-absolute (addr dstate) (declare (type address addr)) @@ -1771,8 +1771,8 @@ (let ((code-size (ash (sb!kernel:get-header-data code) sb!vm:word-shift))) (sb!sys:without-gcing (let ((code-addr (- (sb!kernel:get-lisp-obj-address code) - sb!vm:other-pointer-lowtag))) - (if (or (< addr code-addr) (>= addr (+ code-addr code-size))) + sb!vm:other-pointer-lowtag))) + (if (or (< addr code-addr) (>= addr (+ code-addr code-size))) (values nil nil) (values (sb!kernel:code-header-ref code @@ -1786,7 +1786,7 @@ ;;; Build an address-name hash-table from the name-address hash (defun invert-address-hash (htable &optional (addr-hash (make-hash-table))) (maphash (lambda (name address) - (setf (gethash address addr-hash) name)) + (setf (gethash address addr-hash) name)) htable) addr-hash) @@ -1796,10 +1796,10 @@ (declare (type address address)) (when (null *assembler-routines-by-addr*) (setf *assembler-routines-by-addr* - (invert-address-hash sb!fasl:*assembler-routines*)) + (invert-address-hash sb!fasl:*assembler-routines*)) (setf *assembler-routines-by-addr* - (invert-address-hash sb!sys:*static-foreign-symbols* - *assembler-routines-by-addr*))) + (invert-address-hash sb!sys:*static-foreign-symbols* + *assembler-routines-by-addr*))) (gethash address *assembler-routines-by-addr*)) ;;;; some handy function for machine-dependent code to use... @@ -1808,55 +1808,55 @@ (defun sap-ref-int (sap offset length byte-order) (declare (type sb!sys:system-area-pointer sap) - (type (unsigned-byte 16) offset) - (type (member 1 2 4 8) length) - (type (member :little-endian :big-endian) byte-order) - (optimize (speed 3) (safety 0))) + (type (unsigned-byte 16) offset) + (type (member 1 2 4 8) length) + (type (member :little-endian :big-endian) byte-order) + (optimize (speed 3) (safety 0))) (ecase length (1 (sb!sys:sap-ref-8 sap offset)) (2 (if (eq byte-order :big-endian) - (+ (ash (sb!sys:sap-ref-8 sap offset) 8) - (sb!sys:sap-ref-8 sap (+ offset 1))) - (+ (ash (sb!sys:sap-ref-8 sap (+ offset 1)) 8) - (sb!sys:sap-ref-8 sap offset)))) + (+ (ash (sb!sys:sap-ref-8 sap offset) 8) + (sb!sys:sap-ref-8 sap (+ offset 1))) + (+ (ash (sb!sys:sap-ref-8 sap (+ offset 1)) 8) + (sb!sys:sap-ref-8 sap offset)))) (4 (if (eq byte-order :big-endian) - (+ (ash (sb!sys:sap-ref-8 sap offset) 24) - (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 16) - (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 8) - (sb!sys:sap-ref-8 sap (+ 3 offset))) - (+ (sb!sys:sap-ref-8 sap offset) - (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8) - (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16) - (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24)))) + (+ (ash (sb!sys:sap-ref-8 sap offset) 24) + (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 16) + (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 8) + (sb!sys:sap-ref-8 sap (+ 3 offset))) + (+ (sb!sys:sap-ref-8 sap offset) + (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8) + (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16) + (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24)))) (8 (if (eq byte-order :big-endian) - (+ (ash (sb!sys:sap-ref-8 sap offset) 56) - (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 48) - (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 40) - (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 32) - (ash (sb!sys:sap-ref-8 sap (+ 4 offset)) 24) - (ash (sb!sys:sap-ref-8 sap (+ 5 offset)) 16) - (ash (sb!sys:sap-ref-8 sap (+ 6 offset)) 8) - (sb!sys:sap-ref-8 sap (+ 7 offset))) - (+ (sb!sys:sap-ref-8 sap offset) - (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8) - (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16) - (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24) - (ash (sb!sys:sap-ref-8 sap (+ 4 offset)) 32) - (ash (sb!sys:sap-ref-8 sap (+ 5 offset)) 40) - (ash (sb!sys:sap-ref-8 sap (+ 6 offset)) 48) - (ash (sb!sys:sap-ref-8 sap (+ 7 offset)) 56)))))) + (+ (ash (sb!sys:sap-ref-8 sap offset) 56) + (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 48) + (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 40) + (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 32) + (ash (sb!sys:sap-ref-8 sap (+ 4 offset)) 24) + (ash (sb!sys:sap-ref-8 sap (+ 5 offset)) 16) + (ash (sb!sys:sap-ref-8 sap (+ 6 offset)) 8) + (sb!sys:sap-ref-8 sap (+ 7 offset))) + (+ (sb!sys:sap-ref-8 sap offset) + (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8) + (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16) + (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24) + (ash (sb!sys:sap-ref-8 sap (+ 4 offset)) 32) + (ash (sb!sys:sap-ref-8 sap (+ 5 offset)) 40) + (ash (sb!sys:sap-ref-8 sap (+ 6 offset)) 48) + (ash (sb!sys:sap-ref-8 sap (+ 7 offset)) 56)))))) (defun read-suffix (length dstate) (declare (type (member 8 16 32 64) length) - (type disassem-state dstate) - (optimize (speed 3) (safety 0))) + (type disassem-state dstate) + (optimize (speed 3) (safety 0))) (let ((length (ecase length (8 1) (16 2) (32 4) (64 8)))) (declare (type (unsigned-byte 4) length)) (prog1 (sap-ref-int (dstate-segment-sap dstate) - (dstate-next-offs dstate) - length - (dstate-byte-order dstate)) + (dstate-next-offs dstate) + length + (dstate-byte-order dstate)) (incf (dstate-next-offs dstate) length)))) ;;;; optional routines to make notes about code @@ -1866,7 +1866,7 @@ ;;; after the current instruction is disassembled. (defun note (note dstate) (declare (type (or string function) note) - (type disassem-state dstate)) + (type disassem-state dstate)) (push note (dstate-notes dstate))) (defun prin1-short (thing stream) @@ -1883,13 +1883,13 @@ ;;; comment after the current instruction is disassembled. (defun note-code-constant (byte-offset dstate) (declare (type offset byte-offset) - (type disassem-state dstate)) + (type disassem-state dstate)) (multiple-value-bind (const valid) (get-code-constant byte-offset dstate) (when valid (note (lambda (stream) - (prin1-quoted-short const stream)) - dstate)) + (prin1-quoted-short const stream)) + dstate)) const)) ;;; Store a note about the lisp constant located at ADDR in the @@ -1897,13 +1897,13 @@ ;;; after the current instruction is disassembled. (defun note-code-constant-absolute (addr dstate) (declare (type address addr) - (type disassem-state dstate)) + (type disassem-state dstate)) (multiple-value-bind (const valid) (get-code-constant-absolute addr dstate) (when valid (note (lambda (stream) - (prin1-quoted-short const stream)) - dstate)) + (prin1-quoted-short const stream)) + dstate)) (values const valid))) ;;; If the memory address located NIL-BYTE-OFFSET bytes from the @@ -1913,16 +1913,16 @@ ;;; a note was recorded. (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate) (declare (type offset nil-byte-offset) - (type disassem-state dstate)) + (type disassem-state dstate)) (multiple-value-bind (symbol access-fun) (grok-nil-indexed-symbol-slot-ref nil-byte-offset) (when access-fun (note (lambda (stream) - (prin1 (if (eq access-fun 'symbol-value) - symbol - `(,access-fun ',symbol)) - stream)) - dstate)) + (prin1 (if (eq access-fun 'symbol-value) + symbol + `(,access-fun ',symbol)) + stream)) + dstate)) access-fun)) ;;; If the memory address located NIL-BYTE-OFFSET bytes from the @@ -1932,11 +1932,11 @@ ;;; was recorded. (defun maybe-note-nil-indexed-object (nil-byte-offset dstate) (declare (type offset nil-byte-offset) - (type disassem-state dstate)) + (type disassem-state dstate)) (let ((obj (get-nil-indexed-object nil-byte-offset))) (note (lambda (stream) - (prin1-quoted-short obj stream)) - dstate) + (prin1-quoted-short obj stream)) + dstate) t)) ;;; If ADDRESS is the address of a primitive assembler routine or @@ -1949,15 +1949,15 @@ (unless (typep address 'address) (return-from maybe-note-assembler-routine nil)) (let ((name (or - #!+linkage-table - (sb!sys:sap-foreign-symbol (sb!sys:int-sap address)) - (find-assembler-routine address)))) + #!+linkage-table + (sb!sys:sap-foreign-symbol (sb!sys:int-sap address)) + (find-assembler-routine address)))) (unless (null name) (note (lambda (stream) - (if note-address-p + (if note-address-p (format stream "#x~8,'0x: ~a" address name) (princ name stream))) - dstate)) + dstate)) name)) ;;; If there's a valid mapping from OFFSET in the storage class @@ -1967,18 +1967,18 @@ ;;; recorded. (defun maybe-note-single-storage-ref (offset sc-name dstate) (declare (type offset offset) - (type symbol sc-name) - (type disassem-state dstate)) + (type symbol sc-name) + (type disassem-state dstate)) (let ((storage-location - (find-valid-storage-location offset sc-name dstate))) + (find-valid-storage-location offset sc-name dstate))) (when storage-location (note (lambda (stream) - (princ (sb!di:debug-var-symbol - (aref (storage-info-debug-vars - (seg-storage-info (dstate-segment dstate))) - storage-location)) - stream)) - dstate) + (princ (sb!di:debug-var-symbol + (aref (storage-info-debug-vars + (seg-storage-info (dstate-segment dstate))) + storage-location)) + stream)) + dstate) t))) ;;; If there's a valid mapping from OFFSET in the storage-base called @@ -1988,19 +1988,19 @@ ;;; a note was recorded. (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate) (declare (type offset offset) - (type symbol sb-name) - (type (or symbol string) assoc-with) - (type disassem-state dstate)) + (type symbol sb-name) + (type (or symbol string) assoc-with) + (type disassem-state dstate)) (let ((storage-location - (find-valid-storage-location offset sb-name dstate))) + (find-valid-storage-location offset sb-name dstate))) (when storage-location (note (lambda (stream) - (format stream "~A = ~S" - assoc-with - (sb!di:debug-var-symbol - (aref (dstate-debug-vars dstate) - storage-location)))) - dstate) + (format stream "~A = ~S" + assoc-with + (sb!di:debug-var-symbol + (aref (dstate-debug-vars dstate) + storage-location)))) + dstate) t))) (defun get-internal-error-name (errnum) @@ -2012,9 +2012,9 @@ ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons ;; up a new object? (sb!c:make-random-tn :kind :normal - :sc (svref sb!c:*backend-sc-numbers* - (sb!c:sc-offset-scn sc-offs)) - :offset (sb!c:sc-offset-offset sc-offs)))) + :sc (svref sb!c:*backend-sc-numbers* + (sb!c:sc-offset-scn sc-offs)) + :offset (sb!c:sc-offset-offset sc-offs)))) ;;; When called from an error break instruction's :DISASSEM-CONTROL (or ;;; :DISASSEM-PRINTER) function, will correctly deal with printing the @@ -2034,28 +2034,28 @@ ;;; of the return values. (defun handle-break-args (error-parse-fun stream dstate) (declare (type function error-parse-fun) - (type (or null stream) stream) - (type disassem-state dstate)) + (type (or null stream) stream) + (type disassem-state dstate)) (multiple-value-bind (errnum adjust sc-offsets lengths) (funcall error-parse-fun - (dstate-segment-sap dstate) - (dstate-next-offs dstate) - (null stream)) + (dstate-segment-sap dstate) + (dstate-next-offs dstate) + (null stream)) (when stream (setf (dstate-cur-offs dstate) - (dstate-next-offs dstate)) + (dstate-next-offs dstate)) (flet ((emit-err-arg (note) - (let ((num (pop lengths))) - (print-notes-and-newline stream dstate) - (print-current-address stream dstate) - (print-inst num stream dstate) - (print-bytes num stream dstate) - (incf (dstate-cur-offs dstate) num) - (when note - (note note dstate))))) - (emit-err-arg nil) - (emit-err-arg (symbol-name (get-internal-error-name errnum))) - (dolist (sc-offs sc-offsets) - (emit-err-arg (get-sc-name sc-offs))))) + (let ((num (pop lengths))) + (print-notes-and-newline stream dstate) + (print-current-address stream dstate) + (print-inst num stream dstate) + (print-bytes num stream dstate) + (incf (dstate-cur-offs dstate) num) + (when note + (note note dstate))))) + (emit-err-arg nil) + (emit-err-arg (symbol-name (get-internal-error-name errnum))) + (dolist (sc-offs sc-offsets) + (emit-err-arg (get-sc-name sc-offs))))) (incf (dstate-next-offs dstate) - adjust))) + adjust))) diff --git a/src/compiler/target-dump.lisp b/src/compiler/target-dump.lisp index 26c7380..1ea911e 100644 --- a/src/compiler/target-dump.lisp +++ b/src/compiler/target-dump.lisp @@ -50,8 +50,8 @@ (dump-integer (array-dimension array i) file)) (with-array-data ((vector array) (start) (end)) (if (and (= start 0) (= end (length vector))) - (sub-dump-object vector file) - (sub-dump-object (subseq vector start end) file))) + (sub-dump-object vector file) + (sub-dump-object (subseq vector start end) file))) (dump-fop 'fop-array file) (dump-word rank file) (eq-save-object array file))) @@ -76,8 +76,8 @@ (dump-fop 'fop-long-float-vector file) (dump-word length file) (dump-raw-bytes vec - (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4) - file))) + (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4) + file))) (defun dump-complex-single-float-vector (vec file) (let ((length (length vec))) @@ -97,15 +97,15 @@ (dump-fop 'fop-complex-long-float-vector file) (dump-word length file) (dump-raw-bytes vec - (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4 2) - file))) + (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4 2) + file))) #!+(and long-float x86) (defun dump-long-float (float file) (declare (long-float float)) (let ((exp-bits (long-float-exp-bits float)) - (high-bits (long-float-high-bits float)) - (low-bits (long-float-low-bits float))) + (high-bits (long-float-high-bits float)) + (low-bits (long-float-low-bits float))) ;; We could get away with DUMP-WORD here, since the x86 has 4-byte words, ;; but we prefer to make things as explicit as possible. ;; --njf, 2004-08-16 @@ -117,9 +117,9 @@ (defun dump-long-float (float file) (declare (long-float float)) (let ((exp-bits (long-float-exp-bits float)) - (high-bits (long-float-high-bits float)) - (mid-bits (long-float-mid-bits float)) - (low-bits (long-float-low-bits float))) + (high-bits (long-float-high-bits float)) + (mid-bits (long-float-mid-bits float)) + (low-bits (long-float-low-bits float))) ;; We could get away with DUMP-WORD here, since the sparc has 4-byte ;; words, but we prefer to make things as explicit as possible. ;; --njf, 2004-08-16 diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index a02797b..78b8d03 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -19,13 +19,13 @@ (if (consp definition-designator) definition-designator (multiple-value-bind (definition env-p) - (function-lambda-expression definition-designator) - (when env-p - (error "~S was defined in a non-null environment." - definition-designator)) - (unless definition - (error "can't find a definition for ~S" definition-designator)) - definition))) + (function-lambda-expression definition-designator) + (when env-p + (error "~S was defined in a non-null environment." + definition-designator)) + (unless definition + (error "can't find a definition for ~S" definition-designator)) + definition))) ;;; Handle the nontrivial case of CL:COMPILE. (defun actually-compile (name definition *lexenv*) @@ -38,75 +38,75 @@ ;; macros SB-C::WITH-COMPILATION-VALUES or ;; CL:WITH-COMPILATION-UNIT. (let* (;; FIXME: Do we need the *INFO-ENVIRONMENT* rebinding - ;; here? It's a literal translation of the old CMU CL - ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT* - ;; *INFO-ENVIRONMENT*), and it's not obvious whether the - ;; rebinding to itself is needed now that SBCL doesn't - ;; need *BACKEND-INFO-ENVIRONMENT*. - (*info-environment* *info-environment*) - (form (get-lambda-to-compile definition)) - (*source-info* (make-lisp-source-info form)) - (*toplevel-lambdas* ()) - (*block-compile* nil) + ;; here? It's a literal translation of the old CMU CL + ;; rebinding to (OR *BACKEND-INFO-ENVIRONMENT* + ;; *INFO-ENVIRONMENT*), and it's not obvious whether the + ;; rebinding to itself is needed now that SBCL doesn't + ;; need *BACKEND-INFO-ENVIRONMENT*. + (*info-environment* *info-environment*) + (form (get-lambda-to-compile definition)) + (*source-info* (make-lisp-source-info form)) + (*toplevel-lambdas* ()) + (*block-compile* nil) (*allow-instrumenting* nil) - (*compiler-error-bailout* - (lambda (&optional error) + (*compiler-error-bailout* + (lambda (&optional error) (declare (ignore error)) - (compiler-mumble - "~2&fatal error, aborting compilation~%") - (return-from actually-compile (values nil t nil)))) - (*current-path* nil) - (*last-source-context* nil) - (*last-original-source* nil) - (*last-source-form* nil) - (*last-format-string* nil) - (*last-format-args* nil) - (*last-message-count* 0) - (*gensym-counter* 0) - ;; KLUDGE: This rebinding of policy is necessary so that - ;; forms such as LOCALLY at the REPL actually extend the - ;; compilation policy correctly. However, there is an - ;; invariant that is potentially violated: future - ;; refactoring must not allow this to be done in the file - ;; compiler. At the moment we're clearly alright, as we - ;; call %COMPILE with a core-object, not a fasl-stream, - ;; but caveat future maintainers. -- CSR, 2002-10-27 - (*policy* (lexenv-policy *lexenv*)) - ;; see above - (*handled-conditions* (lexenv-handled-conditions *lexenv*)) - ;; ditto - (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)) - ;; FIXME: ANSI doesn't say anything about CL:COMPILE - ;; interacting with these variables, so we shouldn't. As - ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by - ;; binding these variables, so as a quick hack we do so - ;; too. But a proper implementation would have verbosity - ;; controlled by function arguments and lexical variables. - (*compile-verbose* nil) - (*compile-print* nil)) - (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) - (clear-stuff) - (find-source-paths form 0) - (%compile form (make-core-object) - :name name - :path '(original-source-start 0 0))))))) + (compiler-mumble + "~2&fatal error, aborting compilation~%") + (return-from actually-compile (values nil t nil)))) + (*current-path* nil) + (*last-source-context* nil) + (*last-original-source* nil) + (*last-source-form* nil) + (*last-format-string* nil) + (*last-format-args* nil) + (*last-message-count* 0) + (*gensym-counter* 0) + ;; KLUDGE: This rebinding of policy is necessary so that + ;; forms such as LOCALLY at the REPL actually extend the + ;; compilation policy correctly. However, there is an + ;; invariant that is potentially violated: future + ;; refactoring must not allow this to be done in the file + ;; compiler. At the moment we're clearly alright, as we + ;; call %COMPILE with a core-object, not a fasl-stream, + ;; but caveat future maintainers. -- CSR, 2002-10-27 + (*policy* (lexenv-policy *lexenv*)) + ;; see above + (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)) + ;; FIXME: ANSI doesn't say anything about CL:COMPILE + ;; interacting with these variables, so we shouldn't. As + ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by + ;; binding these variables, so as a quick hack we do so + ;; too. But a proper implementation would have verbosity + ;; controlled by function arguments and lexical variables. + (*compile-verbose* nil) + (*compile-print* nil)) + (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) + (clear-stuff) + (find-source-paths form 0) + (%compile form (make-core-object) + :name name + :path '(original-source-start 0 0))))))) (defun compile-in-lexenv (name definition lexenv) (multiple-value-bind (compiled-definition warnings-p failure-p) (if (compiled-function-p definition) - (values definition nil nil) - (actually-compile name definition lexenv)) + (values definition nil nil) + (actually-compile name definition lexenv)) (cond (name - (if (and (symbolp name) + (if (and (symbolp name) (macro-function name)) - (setf (macro-function name) compiled-definition) - (setf (fdefinition name) compiled-definition)) - (values name warnings-p failure-p)) - (t - (values compiled-definition warnings-p failure-p))))) + (setf (macro-function name) compiled-definition) + (setf (fdefinition name) compiled-definition)) + (values name warnings-p failure-p)) + (t + (values compiled-definition warnings-p failure-p))))) (defun compile (name &optional (definition (or (macro-function name) - (fdefinition name)))) + (fdefinition name)))) #!+sb-doc "Coerce DEFINITION (by default, the function whose name is NAME) to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P), @@ -114,15 +114,15 @@ otherwise THING is NAME. When NAME is not NIL, the compiled function is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into (FDEFINITION NAME) otherwise." - (multiple-value-bind (function warnings-p failure-p) + (multiple-value-bind (function warnings-p failure-p) (compile-in-lexenv name definition (make-null-lexenv)) (values (or function - name - (lambda (&rest arguments) - (error 'simple-program-error - :format-control - "Called function compiled with errors. Original ~ + name + (lambda (&rest arguments) + (error 'simple-program-error + :format-control + "Called function compiled with errors. Original ~ definition:~% ~S~@[~%Arguments:~% ~{ ~S~}~]" - :format-arguments (list definition arguments)))) - warnings-p - failure-p))) + :format-arguments (list definition arguments)))) + warnings-p + failure-p))) diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index d5e6f77..d044d21 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -23,15 +23,15 @@ (let ((n-component (gensym))) `(let ((,n-component (component-info ,component))) (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn))) - ((null ,tn)) - ,@body) + ((null ,tn)) + ,@body) (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn))) - ((null ,tn)) - ,@body) + ((null ,tn)) + ,@body) (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn))) - ((null ,tn) - ,result) - ,@body)))) + ((null ,tn) + ,result) + ,@body)))) (defun set-ir2-physenv-live-tns (value instance) (setf (ir2-physenv-live-tns instance) value)) @@ -57,52 +57,52 @@ ;;; aliased TNs aren't considered to be unreferenced. (defun delete-unreferenced-tns (component) (let* ((2comp (component-info component)) - (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp)) - :element-type 'bit :initial-element 0))) + (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp)) + :element-type 'bit :initial-element 0))) (labels ((delete-some (getter setter) - (let ((prev nil)) - (do ((tn (funcall getter 2comp) (tn-next tn))) - ((null tn)) - (cond - ((or (used-p tn) - (and (eq (tn-kind tn) :specified-save) - (used-p (tn-save-tn tn)))) - (setq prev tn)) - (t - (delete-1 tn prev setter)))))) - (used-p (tn) - (or (tn-reads tn) (tn-writes tn) - (member (tn-kind tn) '(:component :environment)) - (not (zerop (sbit aliases (tn-number tn)))))) - (delete-1 (tn prev setter) - (if prev - (setf (tn-next prev) (tn-next tn)) - (funcall setter (tn-next tn) 2comp)) - (setf (tn-offset tn) nil) - (case (tn-kind tn) - (:environment - (clear-live tn - #'ir2-physenv-live-tns - #'set-ir2-physenv-live-tns)) - (:debug-environment - (clear-live tn - #'ir2-physenv-debug-live-tns - #'set-ir2-physenv-debug-live-tns)))) - (clear-live (tn getter setter) - (let ((env (physenv-info (tn-physenv tn)))) - (funcall setter (delete tn (funcall getter env)) env)))) + (let ((prev nil)) + (do ((tn (funcall getter 2comp) (tn-next tn))) + ((null tn)) + (cond + ((or (used-p tn) + (and (eq (tn-kind tn) :specified-save) + (used-p (tn-save-tn tn)))) + (setq prev tn)) + (t + (delete-1 tn prev setter)))))) + (used-p (tn) + (or (tn-reads tn) (tn-writes tn) + (member (tn-kind tn) '(:component :environment)) + (not (zerop (sbit aliases (tn-number tn)))))) + (delete-1 (tn prev setter) + (if prev + (setf (tn-next prev) (tn-next tn)) + (funcall setter (tn-next tn) 2comp)) + (setf (tn-offset tn) nil) + (case (tn-kind tn) + (:environment + (clear-live tn + #'ir2-physenv-live-tns + #'set-ir2-physenv-live-tns)) + (:debug-environment + (clear-live tn + #'ir2-physenv-debug-live-tns + #'set-ir2-physenv-debug-live-tns)))) + (clear-live (tn getter setter) + (let ((env (physenv-info (tn-physenv tn)))) + (funcall setter (delete tn (funcall getter env)) env)))) (declare (inline used-p delete-some delete-1 clear-live)) (delete-some #'ir2-component-alias-tns - #'set-ir2-component-alias-tns) + #'set-ir2-component-alias-tns) (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn))) - ((null tn)) - (setf (sbit aliases (tn-number (tn-save-tn tn))) 1)) + ((null tn)) + (setf (sbit aliases (tn-number (tn-save-tn tn))) 1)) (delete-some #'ir2-component-normal-tns - #'set-ir2-component-normal-tns) + #'set-ir2-component-normal-tns) (delete-some #'ir2-component-restricted-tns - #'set-ir2-component-restricted-tns) + #'set-ir2-component-restricted-tns) (delete-some #'ir2-component-wired-tns - #'set-ir2-component-wired-tns))) + #'set-ir2-component-wired-tns))) (values)) ;;;; TN creation @@ -113,8 +113,8 @@ (defun make-normal-tn (type) (declare (type primitive-type type)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal type nil))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :normal type nil))) (push-in tn-next res (ir2-component-normal-tns component)) res)) @@ -122,9 +122,9 @@ (defun make-representation-tn (ptype scn) (declare (type primitive-type ptype) (type sc-number scn)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal ptype - (svref *backend-sc-numbers* scn)))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :normal ptype + (svref *backend-sc-numbers* scn)))) (push-in tn-next res (ir2-component-normal-tns component)) res)) @@ -134,11 +134,11 @@ ;;; temporaries. (defun make-wired-tn (ptype scn offset) (declare (type (or primitive-type null) ptype) - (type sc-number scn) (type unsigned-byte offset)) + (type sc-number scn) (type unsigned-byte offset)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal ptype - (svref *backend-sc-numbers* scn)))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :normal ptype + (svref *backend-sc-numbers* scn)))) (setf (tn-offset res) offset) (push-in tn-next res (ir2-component-wired-tns component)) res)) @@ -148,9 +148,9 @@ (defun make-restricted-tn (ptype scn) (declare (type (or primitive-type null) ptype) (type sc-number scn)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :normal ptype - (svref *backend-sc-numbers* scn)))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :normal ptype + (svref *backend-sc-numbers* scn)))) (push-in tn-next res (ir2-component-restricted-tns component)) res)) @@ -180,7 +180,7 @@ (aver (eq (tn-kind tn) :normal)) (setf (tn-kind tn) :component) (push tn (ir2-component-component-tns (component-info - *component-being-compiled*))) + *component-being-compiled*))) tn) ;;; Specify that SAVE be used as the save location for TN. TN is returned. @@ -192,8 +192,8 @@ (setf (tn-save-tn tn) save) (setf (tn-save-tn save) tn) (push save - (ir2-component-specified-save-tns - (component-info *component-being-compiled*))) + (ir2-component-specified-save-tns + (component-info *component-being-compiled*))) tn) ;;; Create a constant TN. The implementation dependent @@ -202,24 +202,24 @@ (defun make-constant-tn (constant) (declare (type constant constant)) (let* ((component (component-info *component-being-compiled*)) - (immed (immediate-constant-sc (constant-value constant))) - (sc (svref *backend-sc-numbers* - (or immed (sc-number-or-lose 'constant)))) - (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc))) + (immed (immediate-constant-sc (constant-value constant))) + (sc (svref *backend-sc-numbers* + (or immed (sc-number-or-lose 'constant)))) + (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc))) (unless immed (let ((constants (ir2-component-constants component))) - (setf (tn-offset res) (fill-pointer constants)) - (vector-push-extend constant constants))) + (setf (tn-offset res) (fill-pointer constants)) + (vector-push-extend constant constants))) (push-in tn-next res (ir2-component-constant-tns component)) (setf (tn-leaf res) constant) res)) (defun make-load-time-value-tn (handle type) (let* ((component (component-info *component-being-compiled*)) - (sc (svref *backend-sc-numbers* - (sc-number-or-lose 'constant))) - (res (make-tn 0 :constant (primitive-type type) sc)) - (constants (ir2-component-constants component))) + (sc (svref *backend-sc-numbers* + (sc-number-or-lose 'constant))) + (res (make-tn 0 :constant (primitive-type type) sc)) + (constants (ir2-component-constants component))) (setf (tn-offset res) (fill-pointer constants)) (vector-push-extend (cons :load-time-value handle) constants) (push-in tn-next res (ir2-component-constant-tns component)) @@ -229,11 +229,11 @@ (defun make-alias-tn (tn) (declare (type tn tn)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn (incf (ir2-component-global-tn-counter component)) - :alias (tn-primitive-type tn) nil))) + (res (make-tn (incf (ir2-component-global-tn-counter component)) + :alias (tn-primitive-type tn) nil))) (setf (tn-save-tn res) tn) (push-in tn-next res - (ir2-component-alias-tns component)) + (ir2-component-alias-tns component)) res)) ;;; Return a load-time constant TN with the specified KIND and INFO. @@ -242,25 +242,25 @@ (defun make-load-time-constant-tn (kind info) (declare (type keyword kind)) (let* ((component (component-info *component-being-compiled*)) - (res (make-tn 0 - :constant - *backend-t-primitive-type* - (svref *backend-sc-numbers* - (sc-number-or-lose 'constant)))) - (constants (ir2-component-constants component))) + (res (make-tn 0 + :constant + *backend-t-primitive-type* + (svref *backend-sc-numbers* + (sc-number-or-lose 'constant)))) + (constants (ir2-component-constants component))) (do ((i 0 (1+ i))) - ((= i (length constants)) - (setf (tn-offset res) i) - (vector-push-extend (cons kind info) constants)) + ((= i (length constants)) + (setf (tn-offset res) i) + (vector-push-extend (cons kind info) constants)) (let ((entry (aref constants i))) - (when (and (consp entry) - (eq (car entry) kind) - (or (eq (cdr entry) info) - (and (consp info) - (equal (cdr entry) info)))) - (setf (tn-offset res) i) - (return)))) + (when (and (consp entry) + (eq (car entry) kind) + (or (eq (cdr entry) info) + (and (consp info) + (equal (cdr entry) info)))) + (setf (tn-offset res) i) + (return)))) (push-in tn-next res (ir2-component-constant-tns component)) res)) @@ -275,8 +275,8 @@ (declare (type tn tn) (type boolean write-p)) (let ((res (make-tn-ref tn write-p))) (if write-p - (push-in tn-ref-next res (tn-writes tn)) - (push-in tn-ref-next res (tn-reads tn))) + (push-in tn-ref-next res (tn-writes tn)) + (push-in tn-ref-next res (tn-reads tn))) res)) ;;; Make TN-REFS to reference each TN in TNs, linked together by @@ -287,13 +287,13 @@ (declare (list tns) (type boolean write-p) (type (or tn-ref null) more)) (if tns (let* ((first (reference-tn (first tns) write-p)) - (prev first)) - (dolist (tn (rest tns)) - (let ((res (reference-tn tn write-p))) - (setf (tn-ref-across prev) res) - (setq prev res))) - (setf (tn-ref-across prev) more) - first) + (prev first)) + (dolist (tn (rest tns)) + (let ((res (reference-tn tn write-p))) + (setf (tn-ref-across prev) res) + (setq prev res))) + (setf (tn-ref-across prev) more) + first) more)) ;;; Remove Ref from the references for its associated TN. @@ -324,49 +324,49 @@ ;;; inserted. (defun emit-move-template (node block template x y &optional before) (declare (type node node) (type ir2-block block) - (type template template) (type tn x y)) + (type template template) (type tn x y)) (let ((arg (reference-tn x nil)) - (result (reference-tn y t))) + (result (reference-tn y t))) (multiple-value-bind (first last) - (funcall (template-emit-function template) node block template arg - result) + (funcall (template-emit-function template) node block template arg + result) (insert-vop-sequence first last block before) last))) ;;; like EMIT-MOVE-TEMPLATE, except that we pass in INFO args too (defun emit-load-template (node block template x y info &optional before) (declare (type node node) (type ir2-block block) - (type template template) (type tn x y)) + (type template template) (type tn x y)) (let ((arg (reference-tn x nil)) - (result (reference-tn y t))) + (result (reference-tn y t))) (multiple-value-bind (first last) - (funcall (template-emit-function template) node block template arg - result info) + (funcall (template-emit-function template) node block template arg + result info) (insert-vop-sequence first last block before) last))) ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes two args (defun emit-move-arg-template (node block template x f y &optional before) (declare (type node node) (type ir2-block block) - (type template template) (type tn x f y)) + (type template template) (type tn x f y)) (let ((x-ref (reference-tn x nil)) - (f-ref (reference-tn f nil)) - (y-ref (reference-tn y t))) + (f-ref (reference-tn f nil)) + (y-ref (reference-tn y t))) (setf (tn-ref-across x-ref) f-ref) (multiple-value-bind (first last) - (funcall (template-emit-function template) node block template x-ref - y-ref) + (funcall (template-emit-function template) node block template x-ref + y-ref) (insert-vop-sequence first last block before) last))) ;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes no args (defun emit-context-template (node block template y &optional before) (declare (type node node) (type ir2-block block) - (type template template) (type tn y)) + (type template template) (type tn y)) (let ((y-ref (reference-tn y t))) (multiple-value-bind (first last) - (funcall (template-emit-function template) node block template nil - y-ref) + (funcall (template-emit-function template) node block template nil + y-ref) (insert-vop-sequence first last block before) last))) @@ -375,7 +375,7 @@ (declare (type cblock block)) (let ((2block (block-info block))) (or (ir2-block-%label 2block) - (setf (ir2-block-%label 2block) (gen-label))))) + (setf (ir2-block-%label 2block) (gen-label))))) ;;; Return true if Block is emitted immediately after the block ended by Node. (defun drop-thru-p (node block) @@ -388,21 +388,21 @@ ;;; VOP. If Before is NIL, insert at the end. (defun insert-vop-sequence (first last block before) (declare (type vop first last) (type ir2-block block) - (type (or vop null) before)) + (type (or vop null) before)) (if before (let ((prev (vop-prev before))) - (setf (vop-prev first) prev) - (if prev - (setf (vop-next prev) first) - (setf (ir2-block-start-vop block) first)) - (setf (vop-next last) before) - (setf (vop-prev before) last)) + (setf (vop-prev first) prev) + (if prev + (setf (vop-next prev) first) + (setf (ir2-block-start-vop block) first)) + (setf (vop-next last) before) + (setf (vop-prev before) last)) (let ((current (ir2-block-last-vop block))) - (setf (vop-prev first) current) - (setf (ir2-block-last-vop block) last) - (if current - (setf (vop-next current) first) - (setf (ir2-block-start-vop block) first)))) + (setf (vop-prev first) current) + (setf (ir2-block-last-vop block) last) + (if current + (setf (vop-next current) first) + (setf (ir2-block-start-vop block) first)))) (values)) ;;; Delete all of the TN-REFs associated with VOP and remove VOP from the IR2. @@ -413,14 +413,14 @@ (delete-tn-ref ref)) (let ((prev (vop-prev vop)) - (next (vop-next vop)) - (block (vop-block vop))) + (next (vop-next vop)) + (block (vop-block vop))) (if prev - (setf (vop-next prev) next) - (setf (ir2-block-start-vop block) next)) + (setf (vop-next prev) next) + (setf (ir2-block-start-vop block) next)) (if next - (setf (vop-prev next) prev) - (setf (ir2-block-last-vop block) prev))) + (setf (vop-prev next) prev) + (setf (ir2-block-last-vop block) prev))) (values)) @@ -437,7 +437,7 @@ (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y))) (eql (tn-offset x) (tn-offset y)) (not (or (eq (tn-kind x) :constant) - (eq (tn-kind y) :constant))))) + (eq (tn-kind y) :constant))))) ;;; Return the value of an immediate constant TN. (defun tn-value (tn) @@ -454,13 +454,13 @@ (declare (type tn tn)) (let ((sc (tn-sc tn))) (unless (and (not (sc-save-p sc)) - (eq (sb-kind (sc-sb sc)) :unbounded)) + (eq (sb-kind (sc-sb sc)) :unbounded)) (dolist (alt (sc-alternate-scs sc) - (error "SC ~S has no :UNBOUNDED :SAVE-P NIL alternate SC." - (sc-name sc))) - (when (and (not (sc-save-p alt)) - (eq (sb-kind (sc-sb alt)) :unbounded)) - (setf (tn-sc tn) alt) - (return))))) + (error "SC ~S has no :UNBOUNDED :SAVE-P NIL alternate SC." + (sc-name sc))) + (when (and (not (sc-save-p alt)) + (eq (sb-kind (sc-sb alt)) :unbounded)) + (setf (tn-sc tn) alt) + (return))))) (values)) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 612d2bc..e88f366 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -43,9 +43,9 @@ (let ((type (specifier-type specifier))) (setf (gethash name *backend-predicate-types*) type) (setf *backend-type-predicates* - (cons (cons type name) - (remove name *backend-type-predicates* - :key #'cdr))) + (cons (cons type name) + (remove name *backend-type-predicates* + :key #'cdr))) (%deftransform name '(function (t) *) #'fold-type-predicate) name)) @@ -69,13 +69,13 @@ (declare (type lvar object) (type ctype type)) (let ((otype (lvar-type object))) (cond ((not (types-equal-or-intersect otype type)) - nil) - ((csubtypep otype type) - t) + nil) + ((csubtypep otype type) + t) ((eq type *empty-type*) nil) - (t - (give-up-ir1-transform))))) + (t + (give-up-ir1-transform))))) ;;; Flush %TYPEP tests whose result is known at compile time. (deftransform %typep ((object type)) @@ -90,10 +90,10 @@ ;;; appropriate type, expanding to T or NIL as appropriate. (deftransform fold-type-predicate ((object) * * :node node :defun-only t) (let ((ctype (gethash (leaf-source-name - (ref-leaf - (lvar-uses - (basic-combination-fun node)))) - *backend-predicate-types*))) + (ref-leaf + (lvar-uses + (basic-combination-fun node)))) + *backend-predicate-types*))) (aver ctype) (ir1-transform-type-predicate object ctype))) @@ -101,9 +101,9 @@ ;;; at load time. (deftransform find-classoid ((name) ((constant-arg symbol)) *) (let* ((name (lvar-value name)) - (cell (find-classoid-cell name))) + (cell (find-classoid-cell name))) `(or (classoid-cell-classoid ',cell) - (error "class not yet defined: ~S" name)))) + (error "class not yet defined: ~S" name)))) ;;;; standard type predicates, i.e. those defined in package COMMON-LISP, ;;;; plus at least one oddball (%INSTANCEP) @@ -161,17 +161,17 @@ (defun transform-numeric-bound-test (n-object type base) (declare (type numeric-type type)) (let ((low (numeric-type-low type)) - (high (numeric-type-high type))) + (high (numeric-type-high type))) `(locally (declare (optimize (safety 0))) (and ,@(when low - (if (consp low) - `((> (truly-the ,base ,n-object) ,(car low))) - `((>= (truly-the ,base ,n-object) ,low)))) - ,@(when high - (if (consp high) - `((< (truly-the ,base ,n-object) ,(car high))) - `((<= (truly-the ,base ,n-object) ,high)))))))) + (if (consp low) + `((> (truly-the ,base ,n-object) ,(car low))) + `((>= (truly-the ,base ,n-object) ,low)))) + ,@(when high + (if (consp high) + `((< (truly-the ,base ,n-object) ,(car high))) + `((<= (truly-the ,base ,n-object) ,high)))))))) ;;; Do source transformation of a test of a known numeric type. We can ;;; assume that the type doesn't have a corresponding predicate, since @@ -191,32 +191,32 @@ ;;; realpart and the imagpart must be the same. (defun source-transform-numeric-typep (object type) (let* ((class (numeric-type-class type)) - (base (ecase class - (integer (containing-integer-type + (base (ecase class + (integer (containing-integer-type (if (numeric-type-complexp type) (modified-numeric-type type :complexp :real) type))) - (rational 'rational) - (float (or (numeric-type-format type) 'float)) - ((nil) 'real)))) + (rational 'rational) + (float (or (numeric-type-format type) 'float)) + ((nil) 'real)))) (once-only ((n-object object)) (ecase (numeric-type-complexp type) - (:real - `(and (typep ,n-object ',base) - ,(transform-numeric-bound-test n-object type base))) - (:complex - `(and (complexp ,n-object) - ,(once-only ((n-real `(realpart (truly-the complex ,n-object))) - (n-imag `(imagpart (truly-the complex ,n-object)))) - `(progn - ,n-imag ; ignorable - (and (typep ,n-real ',base) - ,@(when (eq class 'integer) - `((typep ,n-imag ',base))) - ,(transform-numeric-bound-test n-real type base) - ,(transform-numeric-bound-test n-imag type - base)))))))))) + (:real + `(and (typep ,n-object ',base) + ,(transform-numeric-bound-test n-object type base))) + (:complex + `(and (complexp ,n-object) + ,(once-only ((n-real `(realpart (truly-the complex ,n-object))) + (n-imag `(imagpart (truly-the complex ,n-object)))) + `(progn + ,n-imag ; ignorable + (and (typep ,n-real ',base) + ,@(when (eq class 'integer) + `((typep ,n-imag ',base))) + ,(transform-numeric-bound-test n-real type base) + ,(transform-numeric-bound-test n-imag type + base)))))))))) ;;; Do the source transformation for a test of a hairy type. AND, ;;; SATISFIES and NOT are converted into the obvious code. We convert @@ -226,18 +226,18 @@ (declare (type hairy-type type)) (let ((spec (hairy-type-specifier type))) (cond ((unknown-type-p type) - (when (policy *lexenv* (> speed inhibit-warnings)) - (compiler-notify "can't open-code test of unknown type ~S" - (type-specifier type))) - `(%typep ,object ',spec)) - (t - (ecase (first spec) - (satisfies `(if (funcall #',(second spec) ,object) t nil)) - ((not and) - (once-only ((n-obj object)) - `(,(first spec) ,@(mapcar (lambda (x) - `(typep ,n-obj ',x)) - (rest spec)))))))))) + (when (policy *lexenv* (> speed inhibit-warnings)) + (compiler-notify "can't open-code test of unknown type ~S" + (type-specifier type))) + `(%typep ,object ',spec)) + (t + (ecase (first spec) + (satisfies `(if (funcall #',(second spec) ,object) t nil)) + ((not and) + (once-only ((n-obj object)) + `(,(first spec) ,@(mapcar (lambda (x) + `(typep ,n-obj ',x)) + (rest spec)))))))))) (defun source-transform-negation-typep (object type) (declare (type negation-type type)) @@ -254,47 +254,47 @@ (defun source-transform-union-typep (object type) (let* ((types (union-type-types type)) (type-cons (specifier-type 'cons)) - (mtype (find-if #'member-type-p types)) + (mtype (find-if #'member-type-p types)) (members (when mtype (member-type-members mtype)))) (if (and mtype (memq nil members) (memq type-cons types)) - (once-only ((n-obj object)) + (once-only ((n-obj object)) `(or (listp ,n-obj) (typep ,n-obj '(or ,@(mapcar #'type-specifier (remove type-cons (remove mtype types))) (member ,@(remove nil members)))))) - (once-only ((n-obj object)) - `(or ,@(mapcar (lambda (x) - `(typep ,n-obj ',(type-specifier x))) - types)))))) + (once-only ((n-obj object)) + `(or ,@(mapcar (lambda (x) + `(typep ,n-obj ',(type-specifier x))) + types)))))) ;;; Do source transformation for TYPEP of a known intersection type. (defun source-transform-intersection-typep (object type) (once-only ((n-obj object)) `(and ,@(mapcar (lambda (x) - `(typep ,n-obj ',(type-specifier x))) - (intersection-type-types type))))) + `(typep ,n-obj ',(type-specifier x))) + (intersection-type-types type))))) ;;; If necessary recurse to check the cons type. (defun source-transform-cons-typep (object type) (let* ((car-type (cons-type-car-type type)) - (cdr-type (cons-type-cdr-type type))) + (cdr-type (cons-type-cdr-type type))) (let ((car-test-p (not (type= car-type *universal-type*))) - (cdr-test-p (not (type= cdr-type *universal-type*)))) + (cdr-test-p (not (type= cdr-type *universal-type*)))) (if (and (not car-test-p) (not cdr-test-p)) - `(consp ,object) - (once-only ((n-obj object)) - `(and (consp ,n-obj) - ,@(if car-test-p - `((typep (car ,n-obj) - ',(type-specifier car-type)))) - ,@(if cdr-test-p - `((typep (cdr ,n-obj) - ',(type-specifier cdr-type)))))))))) - + `(consp ,object) + (once-only ((n-obj object)) + `(and (consp ,n-obj) + ,@(if car-test-p + `((typep (car ,n-obj) + ',(type-specifier car-type)))) + ,@(if cdr-test-p + `((typep (cdr ,n-obj) + ',(type-specifier cdr-type)))))))))) + (defun source-transform-character-set-typep (object type) (let ((pairs (character-set-type-pairs type))) (if (and (= (length pairs) 1) @@ -315,14 +315,14 @@ (defun find-supertype-predicate (type) (declare (type ctype type)) (let ((res nil) - (res-type nil)) + (res-type nil)) (dolist (x *backend-type-predicates*) (let ((stype (car x))) - (when (and (csubtypep type stype) - (or (not res-type) - (csubtypep stype res-type))) - (setq res-type stype) - (setq res (cdr x))))) + (when (and (csubtypep type stype) + (or (not res-type) + (csubtypep stype res-type))) + (setq res-type stype) + (setq res (cdr x))))) (values res res-type))) ;;; Return forms to test that OBJ has the rank and dimensions @@ -331,19 +331,19 @@ (defun test-array-dimensions (obj type stype) (declare (type array-type type stype)) (let ((obj `(truly-the ,(type-specifier stype) ,obj)) - (dims (array-type-dimensions type))) + (dims (array-type-dimensions type))) (unless (or (eq dims '*) - (equal dims (array-type-dimensions stype))) + (equal dims (array-type-dimensions stype))) (collect ((res)) - (when (eq (array-type-dimensions stype) '*) - (res `(= (array-rank ,obj) ,(length dims)))) - (do ((i 0 (1+ i)) - (dim dims (cdr dim))) - ((null dim)) - (let ((dim (car dim))) - (unless (eq dim '*) - (res `(= (array-dimension ,obj ,i) ,dim))))) - (res))))) + (when (eq (array-type-dimensions stype) '*) + (res `(= (array-rank ,obj) ,(length dims)))) + (do ((i 0 (1+ i)) + (dim dims (cdr dim))) + ((null dim)) + (let ((dim (car dim))) + (unless (eq dim '*) + (res `(= (array-dimension ,obj ,i) ,dim))))) + (res))))) ;;; Return forms to test that OBJ has the element-type specified by ;;; type specified by TYPE, where STYPE is the type we have checked @@ -351,17 +351,17 @@ (defun test-array-element-type (obj type stype) (declare (type array-type type stype)) (let ((obj `(truly-the ,(type-specifier stype) ,obj)) - (eltype (array-type-specialized-element-type type))) + (eltype (array-type-specialized-element-type type))) (unless (type= eltype (array-type-specialized-element-type stype)) (with-unique-names (data) - `((do ((,data ,obj (%array-data-vector ,data))) - ((not (array-header-p ,data)) - ;; KLUDGE: this isn't in fact maximally efficient, - ;; because though we know that DATA is a (SIMPLE-ARRAY * - ;; (*)), we will still check to see if the lowtag is - ;; appropriate. - (typep ,data - '(simple-array ,(type-specifier eltype) (*)))))))))) + `((do ((,data ,obj (%array-data-vector ,data))) + ((not (array-header-p ,data)) + ;; KLUDGE: this isn't in fact maximally efficient, + ;; because though we know that DATA is a (SIMPLE-ARRAY * + ;; (*)), we will still check to see if the lowtag is + ;; appropriate. + (typep ,data + '(simple-array ,(type-specifier eltype) (*)))))))))) ;;; If we can find a type predicate that tests for the type without ;;; dimensions, then use that predicate and test for dimensions. @@ -369,16 +369,16 @@ (defun source-transform-array-typep (obj type) (multiple-value-bind (pred stype) (find-supertype-predicate type) (if (and (array-type-p stype) - ;; (If the element type hasn't been defined yet, it's - ;; not safe to assume here that it will eventually - ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.) - (not (unknown-type-p (array-type-element-type type))) - (eq (array-type-complexp stype) (array-type-complexp type))) - (once-only ((n-obj obj)) - `(and (,pred ,n-obj) - ,@(test-array-dimensions n-obj type stype) - ,@(test-array-element-type n-obj type stype))) - `(%typep ,obj ',(type-specifier type))))) + ;; (If the element type hasn't been defined yet, it's + ;; not safe to assume here that it will eventually + ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.) + (not (unknown-type-p (array-type-element-type type))) + (eq (array-type-complexp stype) (array-type-complexp type))) + (once-only ((n-obj obj)) + `(and (,pred ,n-obj) + ,@(test-array-dimensions n-obj type stype) + ,@(test-array-element-type n-obj type stype))) + `(%typep ,obj ',(type-specifier type))))) ;;; Transform a type test against some instance type. The type test is ;;; flushed if the result is known at compile time. If not properly @@ -391,13 +391,13 @@ (deftransform %instance-typep ((object spec) (* *) * :node node) (aver (constant-lvar-p spec)) (let* ((spec (lvar-value spec)) - (class (specifier-type spec)) - (name (classoid-name class)) - (otype (lvar-type object)) - (layout (let ((res (info :type :compiler-layout name))) - (if (and res (not (layout-invalid res))) - res - nil)))) + (class (specifier-type spec)) + (name (classoid-name class)) + (otype (lvar-type object)) + (layout (let ((res (info :type :compiler-layout name))) + (if (and res (not (layout-invalid res))) + res + nil)))) (cond ;; Flush tests whose result is known at compile time. ((not (types-equal-or-intersect otype class)) @@ -408,72 +408,72 @@ ((not (and name (eq (find-classoid name) class))) (compiler-error "can't compile TYPEP of anonymous or undefined ~ class:~% ~S" - class)) + class)) (t ;; Delay the type transform to give type propagation a chance. (delay-ir1-transform node :constraint) ;; Otherwise transform the type test. (multiple-value-bind (pred get-layout) - (cond - ((csubtypep class (specifier-type 'funcallable-instance)) - (values 'funcallable-instance-p '%funcallable-instance-layout)) - ((csubtypep class (specifier-type 'instance)) - (values '%instancep '%instance-layout)) - (t - (values '(lambda (x) (declare (ignore x)) t) 'layout-of))) - (cond - ((and (eq (classoid-state class) :sealed) layout - (not (classoid-subclasses class))) - ;; Sealed and has no subclasses. - (let ((n-layout (gensym))) - `(and (,pred object) - (let ((,n-layout (,get-layout object))) - ,@(when (policy *lexenv* (>= safety speed)) - `((when (layout-invalid ,n-layout) - (%layout-invalid-error object ',layout)))) - (eq ,n-layout ',layout))))) - ((and (typep class 'basic-structure-classoid) layout) - ;; structure type tests; hierarchical layout depths - (let ((depthoid (layout-depthoid layout)) - (n-layout (gensym))) - `(and (,pred object) - (let ((,n-layout (,get-layout object))) - ,@(when (policy *lexenv* (>= safety speed)) - `((when (layout-invalid ,n-layout) - (%layout-invalid-error object ',layout)))) - (if (eq ,n-layout ',layout) - t - (and (> (layout-depthoid ,n-layout) - ,depthoid) - (locally (declare (optimize (safety 0))) - (eq (svref (layout-inherits ,n-layout) - ,depthoid) - ',layout)))))))) + (cond + ((csubtypep class (specifier-type 'funcallable-instance)) + (values 'funcallable-instance-p '%funcallable-instance-layout)) + ((csubtypep class (specifier-type 'instance)) + (values '%instancep '%instance-layout)) + (t + (values '(lambda (x) (declare (ignore x)) t) 'layout-of))) + (cond + ((and (eq (classoid-state class) :sealed) layout + (not (classoid-subclasses class))) + ;; Sealed and has no subclasses. + (let ((n-layout (gensym))) + `(and (,pred object) + (let ((,n-layout (,get-layout object))) + ,@(when (policy *lexenv* (>= safety speed)) + `((when (layout-invalid ,n-layout) + (%layout-invalid-error object ',layout)))) + (eq ,n-layout ',layout))))) + ((and (typep class 'basic-structure-classoid) layout) + ;; structure type tests; hierarchical layout depths + (let ((depthoid (layout-depthoid layout)) + (n-layout (gensym))) + `(and (,pred object) + (let ((,n-layout (,get-layout object))) + ,@(when (policy *lexenv* (>= safety speed)) + `((when (layout-invalid ,n-layout) + (%layout-invalid-error object ',layout)))) + (if (eq ,n-layout ',layout) + t + (and (> (layout-depthoid ,n-layout) + ,depthoid) + (locally (declare (optimize (safety 0))) + (eq (svref (layout-inherits ,n-layout) + ,depthoid) + ',layout)))))))) ((and layout (>= (layout-depthoid layout) 0)) - ;; hierarchical layout depths for other things (e.g. - ;; CONDITIONs) - (let ((depthoid (layout-depthoid layout)) - (n-layout (gensym)) - (n-inherits (gensym))) - `(and (,pred object) - (let ((,n-layout (,get-layout object))) - ,@(when (policy *lexenv* (>= safety speed)) - `((when (layout-invalid ,n-layout) - (%layout-invalid-error object ',layout)))) - (if (eq ,n-layout ',layout) - t - (let ((,n-inherits (layout-inherits ,n-layout))) - (declare (optimize (safety 0))) - (and (> (length ,n-inherits) ,depthoid) - (eq (svref ,n-inherits ,depthoid) - ',layout)))))))) - (t - (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP") - `(and (,pred object) - (classoid-cell-typep (,get-layout object) - ',(find-classoid-cell name) - object))))))))) + ;; hierarchical layout depths for other things (e.g. + ;; CONDITIONs) + (let ((depthoid (layout-depthoid layout)) + (n-layout (gensym)) + (n-inherits (gensym))) + `(and (,pred object) + (let ((,n-layout (,get-layout object))) + ,@(when (policy *lexenv* (>= safety speed)) + `((when (layout-invalid ,n-layout) + (%layout-invalid-error object ',layout)))) + (if (eq ,n-layout ',layout) + t + (let ((,n-inherits (layout-inherits ,n-layout))) + (declare (optimize (safety 0))) + (and (> (length ,n-inherits) ,depthoid) + (eq (svref ,n-inherits ,depthoid) + ',layout)))))))) + (t + (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP") + `(and (,pred object) + (classoid-cell-typep (,get-layout object) + ',(find-classoid-cell name) + object))))))))) ;;; If the specifier argument is a quoted constant, then we consider ;;; converting into a simple predicate or other stuff. If the type is @@ -487,7 +487,7 @@ ;;; If the type is TYPE= to a type that has a predicate, then expand ;;; to that predicate. Otherwise, we dispatch off of the type's type. ;;; These transformations can increase space, but it is hard to tell -;;; when, so we ignore policy and always do them. +;;; when, so we ignore policy and always do them. (define-source-transform typep (object spec) ;; KLUDGE: It looks bad to only do this on explicitly quoted forms, ;; since that would overlook other kinds of constants. But it turns @@ -497,42 +497,42 @@ ;; weird roundabout way. -- WHN 2001-03-18 (if (and (consp spec) (eq (car spec) 'quote)) (let ((type (careful-specifier-type (cadr spec)))) - (or (when (not type) + (or (when (not type) (compiler-warn "illegal type specifier for TYPEP: ~S" (cadr spec)) `(%typep ,object ,spec)) (let ((pred (cdr (assoc type *backend-type-predicates* - :test #'type=)))) - (when pred `(,pred ,object))) - (typecase type - (hairy-type - (source-transform-hairy-typep object type)) - (negation-type - (source-transform-negation-typep object type)) - (union-type - (source-transform-union-typep object type)) - (intersection-type - (source-transform-intersection-typep object type)) - (member-type - `(if (member ,object ',(member-type-members type)) t)) - (args-type - (compiler-warn "illegal type specifier for TYPEP: ~S" - (cadr spec)) - `(%typep ,object ,spec)) - (t nil)) - (typecase type - (numeric-type - (source-transform-numeric-typep object type)) - (classoid - `(%instance-typep ,object ,spec)) - (array-type - (source-transform-array-typep object type)) - (cons-type - (source-transform-cons-typep object type)) + :test #'type=)))) + (when pred `(,pred ,object))) + (typecase type + (hairy-type + (source-transform-hairy-typep object type)) + (negation-type + (source-transform-negation-typep object type)) + (union-type + (source-transform-union-typep object type)) + (intersection-type + (source-transform-intersection-typep object type)) + (member-type + `(if (member ,object ',(member-type-members type)) t)) + (args-type + (compiler-warn "illegal type specifier for TYPEP: ~S" + (cadr spec)) + `(%typep ,object ,spec)) + (t nil)) + (typecase type + (numeric-type + (source-transform-numeric-typep object type)) + (classoid + `(%instance-typep ,object ,spec)) + (array-type + (source-transform-array-typep object type)) + (cons-type + (source-transform-cons-typep object type)) (character-set-type (source-transform-character-set-typep object type)) - (t nil)) - `(%typep ,object ,spec))) + (t nil)) + `(%typep ,object ,spec))) (values nil t))) ;;;; coercion @@ -552,28 +552,28 @@ (give-up-ir1-transform)) (let ((tspec (ir1-transform-specifier-type (lvar-value type)))) (if (csubtypep (lvar-type x) tspec) - 'x - ;; Note: The THE here makes sure that specifiers like - ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR. - `(the ,(lvar-value type) - ,(cond - ((csubtypep tspec (specifier-type 'double-float)) - '(%double-float x)) - ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) - ((csubtypep tspec (specifier-type 'float)) - '(%single-float x)) - ((and (csubtypep tspec (specifier-type 'simple-vector)) - ;; Can we avoid checking for dimension issues like - ;; (COERCE FOO '(SIMPLE-VECTOR 5)) returning a - ;; vector of length 6? - (or (policy node (< safety 3)) ; no need in unsafe code - (and (array-type-p tspec) ; no need when no dimensions - (equal (array-type-dimensions tspec) '(*))))) - `(if (simple-vector-p x) - x - (replace (make-array (length x)) x))) - ;; FIXME: other VECTOR types? - (t - (give-up-ir1-transform))))))) + 'x + ;; Note: The THE here makes sure that specifiers like + ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR. + `(the ,(lvar-value type) + ,(cond + ((csubtypep tspec (specifier-type 'double-float)) + '(%double-float x)) + ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) + ((csubtypep tspec (specifier-type 'float)) + '(%single-float x)) + ((and (csubtypep tspec (specifier-type 'simple-vector)) + ;; Can we avoid checking for dimension issues like + ;; (COERCE FOO '(SIMPLE-VECTOR 5)) returning a + ;; vector of length 6? + (or (policy node (< safety 3)) ; no need in unsafe code + (and (array-type-p tspec) ; no need when no dimensions + (equal (array-type-dimensions tspec) '(*))))) + `(if (simple-vector-p x) + x + (replace (make-array (length x)) x))) + ;; FIXME: other VECTOR types? + (t + (give-up-ir1-transform))))))) diff --git a/src/compiler/vmdef.lisp b/src/compiler/vmdef.lisp index 5464a85..eef1e30 100644 --- a/src/compiler/vmdef.lisp +++ b/src/compiler/vmdef.lisp @@ -16,18 +16,18 @@ (defun template-or-lose (x) (the template (or (gethash x *backend-template-names*) - (error "~S is not a defined template." x)))) + (error "~S is not a defined template." x)))) ;;; Return the SC structure, SB structure or SC number corresponding ;;; to a name, or die trying. (defun sc-or-lose (x) (the sc (or (gethash x *backend-sc-names*) - (error "~S is not a defined storage class." x)))) + (error "~S is not a defined storage class." x)))) (defun sb-or-lose (x) (the sb (or (gethash x *backend-sb-names*) - (error "~S is not a defined storage base." x)))) + (error "~S is not a defined storage base." x)))) (defun sc-number-or-lose (x) (the sc-number (sc-number (sc-or-lose x)))) @@ -37,11 +37,11 @@ (defun meta-sc-or-lose (x) (the sc (or (gethash x *backend-meta-sc-names*) - (error "~S is not a defined storage class." x)))) + (error "~S is not a defined storage class." x)))) (defun meta-sb-or-lose (x) (the sb (or (gethash x *backend-meta-sb-names*) - (error "~S is not a defined storage base." x)))) + (error "~S is not a defined storage base." x)))) (defun meta-sc-number-or-lose (x) (the sc-number (sc-number (meta-sc-or-lose x)))) @@ -57,20 +57,20 @@ (defun compute-move-costs (from-sc to-sc cost) (declare (type sc from-sc to-sc) (type index cost)) (let ((to-scn (sc-number to-sc)) - (from-costs (sc-load-costs from-sc))) + (from-costs (sc-load-costs from-sc))) (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc))) (let ((vec (sc-move-costs dest-sc)) - (dest-costs (sc-load-costs dest-sc))) - (setf (svref vec (sc-number from-sc)) cost) - (dolist (sc (append (sc-alternate-scs from-sc) - (sc-constant-scs from-sc))) - (let* ((scn (sc-number sc)) - (total (+ (svref from-costs scn) - (svref dest-costs to-scn) - cost)) - (old (svref vec scn))) - (unless (and old (< old total)) - (setf (svref vec scn) total)))))))) + (dest-costs (sc-load-costs dest-sc))) + (setf (svref vec (sc-number from-sc)) cost) + (dolist (sc (append (sc-alternate-scs from-sc) + (sc-constant-scs from-sc))) + (let* ((scn (sc-number sc)) + (total (+ (svref from-costs scn) + (svref dest-costs to-scn) + cost)) + (old (svref vec scn))) + (unless (and old (< old total)) + (setf (svref vec scn) total)))))))) ;;;; primitive type definition @@ -79,7 +79,7 @@ (defun primitive-type-or-lose (name) (the primitive-type (or (gethash name *backend-primitive-type-names*) - (error "~S is not a defined primitive type." name)))) + (error "~S is not a defined primitive type." name)))) ;;; Return true if SC is either one of PTYPE's SC's, or one of those ;;; SC's alternate or constant SCs. @@ -88,11 +88,11 @@ (let ((scn (sc-number sc))) (dolist (allowed (primitive-type-scs ptype) nil) (when (eql allowed scn) - (return t)) + (return t)) (let ((allowed-sc (svref *backend-sc-numbers* allowed))) - (when (or (member sc (sc-alternate-scs allowed-sc)) - (member sc (sc-constant-scs allowed-sc))) - (return t)))))) + (when (or (member sc (sc-alternate-scs allowed-sc)) + (member sc (sc-constant-scs allowed-sc))) + (return t)))))) ;;;; generation of emit functions @@ -119,74 +119,74 @@ (defun %emit-generic-vop (node block template args results info) (let* ((vop (make-vop block node template args results)) - (num-args (vop-info-num-args template)) - (last-arg (1- num-args)) - (num-results (vop-info-num-results template)) - (num-operands (+ num-args num-results)) - (last-result (1- num-operands)) - (ref-ordering (vop-info-ref-ordering template))) + (num-args (vop-info-num-args template)) + (last-arg (1- num-args)) + (num-results (vop-info-num-results template)) + (num-operands (+ num-args num-results)) + (last-result (1- num-operands)) + (ref-ordering (vop-info-ref-ordering template))) (declare (type vop vop) - (type (integer 0 #.max-vop-tn-refs) - num-args num-results num-operands) - (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result)) + (type (integer 0 #.max-vop-tn-refs) + num-args num-results num-operands) + (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result)) (setf (vop-codegen-info vop) info) (unwind-protect - (let ((refs *vop-tn-refs*)) - (declare (type (simple-vector #.max-vop-tn-refs) refs)) - (do ((index 0 (1+ index)) - (ref args (and ref (tn-ref-across ref)))) - ((= index num-args)) - (setf (svref refs index) ref)) - (do ((index num-args (1+ index)) - (ref results (and ref (tn-ref-across ref)))) - ((= index num-operands)) - (setf (svref refs index) ref)) - (let ((temps (vop-info-temps template))) - (when temps - (let ((index num-operands) - (prev nil)) - (dotimes (i (length temps)) - (let* ((temp (aref temps i)) - (tn (if (logbitp 0 temp) - (make-wired-tn nil - (ldb (byte sc-bits 1) temp) - (ash temp (- (1+ sc-bits)))) - (make-restricted-tn nil (ash temp -1)))) - (write-ref (reference-tn tn t))) - ;; KLUDGE: These formulas must be consistent with - ;; those in COMPUTE-REF-ORDERING, and this is - ;; currently maintained by hand. -- WHN - ;; 2002-01-30, paraphrasing APD - (setf (aref refs index) (reference-tn tn nil)) - (setf (aref refs (1+ index)) write-ref) - (if prev - (setf (tn-ref-across prev) write-ref) - (setf (vop-temps vop) write-ref)) - (setf prev write-ref) - (incf index 2)))))) - (let ((prev nil)) - (flet ((add-ref (ref) - (setf (tn-ref-vop ref) vop) - (setf (tn-ref-next-ref ref) prev) - (setf prev ref))) - (declare (inline add-ref)) - (dotimes (i (length ref-ordering)) - (let* ((index (aref ref-ordering i)) - (ref (aref refs index))) - (if (or (= index last-arg) (= index last-result)) - (do ((ref ref (tn-ref-across ref))) - ((null ref)) - (add-ref ref)) - (add-ref ref))))) - (setf (vop-refs vop) prev)) - (let ((targets (vop-info-targets template))) - (when targets - (dotimes (i (length targets)) - (let ((target (aref targets i))) - (target-if-desirable - (aref refs (ldb (byte 8 8) target)) - (aref refs (ldb (byte 8 0) target))))))) - (values vop vop)) + (let ((refs *vop-tn-refs*)) + (declare (type (simple-vector #.max-vop-tn-refs) refs)) + (do ((index 0 (1+ index)) + (ref args (and ref (tn-ref-across ref)))) + ((= index num-args)) + (setf (svref refs index) ref)) + (do ((index num-args (1+ index)) + (ref results (and ref (tn-ref-across ref)))) + ((= index num-operands)) + (setf (svref refs index) ref)) + (let ((temps (vop-info-temps template))) + (when temps + (let ((index num-operands) + (prev nil)) + (dotimes (i (length temps)) + (let* ((temp (aref temps i)) + (tn (if (logbitp 0 temp) + (make-wired-tn nil + (ldb (byte sc-bits 1) temp) + (ash temp (- (1+ sc-bits)))) + (make-restricted-tn nil (ash temp -1)))) + (write-ref (reference-tn tn t))) + ;; KLUDGE: These formulas must be consistent with + ;; those in COMPUTE-REF-ORDERING, and this is + ;; currently maintained by hand. -- WHN + ;; 2002-01-30, paraphrasing APD + (setf (aref refs index) (reference-tn tn nil)) + (setf (aref refs (1+ index)) write-ref) + (if prev + (setf (tn-ref-across prev) write-ref) + (setf (vop-temps vop) write-ref)) + (setf prev write-ref) + (incf index 2)))))) + (let ((prev nil)) + (flet ((add-ref (ref) + (setf (tn-ref-vop ref) vop) + (setf (tn-ref-next-ref ref) prev) + (setf prev ref))) + (declare (inline add-ref)) + (dotimes (i (length ref-ordering)) + (let* ((index (aref ref-ordering i)) + (ref (aref refs index))) + (if (or (= index last-arg) (= index last-result)) + (do ((ref ref (tn-ref-across ref))) + ((null ref)) + (add-ref ref)) + (add-ref ref))))) + (setf (vop-refs vop) prev)) + (let ((targets (vop-info-targets template))) + (when targets + (dotimes (i (length targets)) + (let ((target (aref targets i))) + (target-if-desirable + (aref refs (ldb (byte 8 8) target)) + (aref refs (ldb (byte 8 0) target))))))) + (values vop vop)) (fill *vop-tn-refs* nil)))) ;;;; function translation stuff @@ -196,36 +196,36 @@ (defun adjoin-template (template list) (declare (type template template) (list list)) (sort (cons template - (remove (template-name template) list - :key #'template-name)) - #'<= - :key #'template-cost)) + (remove (template-name template) list + :key #'template-name)) + #'<= + :key #'template-cost)) ;;; Return a function type specifier describing TEMPLATE's type computed ;;; from the operand type restrictions. (defun template-type-specifier (template) (declare (type template template)) (flet ((convert (types more-types) - (flet ((frob (x) - (if (eq x '*) - t - (ecase (first x) - (:or `(or ,@(mapcar #'primitive-type-specifier - (rest x)))) - (:constant `(constant-arg ,(third x))))))) - `(,@(mapcar #'frob types) - ,@(when more-types - `(&rest ,(frob more-types))))))) + (flet ((frob (x) + (if (eq x '*) + t + (ecase (first x) + (:or `(or ,@(mapcar #'primitive-type-specifier + (rest x)))) + (:constant `(constant-arg ,(third x))))))) + `(,@(mapcar #'frob types) + ,@(when more-types + `(&rest ,(frob more-types))))))) (let* ((args (convert (template-arg-types template) - (template-more-args-type template))) - (result-restr (template-result-types template)) - (results (if (eq result-restr :conditional) - '(boolean) - (convert result-restr - (cond ((template-more-results-type template)) - ((/= (length result-restr) 1) '*) - (t nil)))))) + (template-more-args-type template))) + (result-restr (template-result-types template)) + (results (if (eq result-restr :conditional) + '(boolean) + (convert result-restr + (cond ((template-more-results-type template)) + ((/= (length result-restr) 1) '*) + (t nil)))))) `(function ,args - ,(if (= (length results) 1) - (first results) - `(values ,@results)))))) + ,(if (= (length results) 1) + (first results) + `(values ,@results)))))) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index d738a0a..cfcb0f4 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -94,9 +94,9 @@ ;;; ;;; BASIC-COMBINATION-INFO ;;; The template chosen by LTN, or -;;; :FULL if this is definitely a full call. -;;; :FUNNY if this is an oddball thing with IR2-convert. -;;; :LOCAL if this is a local call. +;;; :FULL if this is definitely a full call. +;;; :FUNNY if this is an oddball thing with IR2-convert. +;;; :LOCAL if this is a local call. ;;; ;;; NODE-TAIL-P ;;; After LTN analysis, this is true only in combination nodes that are @@ -106,8 +106,8 @@ ;;; and after IR2 conversion. It is stored in the BLOCK-INFO slot for ;;; the associated block. (defstruct (ir2-block (:include block-annotation) - (:constructor make-ir2-block (block)) - (:copier nil)) + (:constructor make-ir2-block (block)) + (:copier nil)) ;; the IR2-BLOCK's number, which differs from BLOCK's BLOCK-NUMBER ;; if any blocks are split. This is assigned by lifetime analysis. (number nil :type (or index null)) @@ -152,15 +152,15 @@ ;; index for a TN is non-zero in WRITTEN if it is ever written in ;; the block, and in LIVE-OUT if the first reference is a read. (written (make-array local-tn-limit :element-type 'bit - :initial-element 0) - :type local-tn-bit-vector) + :initial-element 0) + :type local-tn-bit-vector) (live-out (make-array local-tn-limit :element-type 'bit) - :type local-tn-bit-vector) + :type local-tn-bit-vector) ;; This is similar to the above, but is updated by lifetime flow ;; analysis to have a 1 for LTN numbers of TNs live at the end of ;; the block. This takes into account all TNs that aren't :LIVE. (live-in (make-array local-tn-limit :element-type 'bit :initial-element 0) - :type local-tn-bit-vector) + :type local-tn-bit-vector) ;; a thread running through the global-conflicts structures for this ;; block, sorted by TN number (global-tns nil :type (or global-conflicts null)) @@ -182,8 +182,8 @@ ;;; An IR2-LVAR structure is used to annotate LVARs that are used as a ;;; function result LVARs or that receive MVs. (defstruct (ir2-lvar - (:constructor make-ir2-lvar (primitive-type)) - (:copier nil)) + (:constructor make-ir2-lvar (primitive-type)) + (:copier nil)) ;; If this is :DELAYED, then this is a single value LVAR for which ;; the evaluation of the use is to be postponed until the evaluation ;; of destination. This can be done for ref nodes or predicates @@ -275,7 +275,7 @@ ;; Is replaced by the code pointer for the specified function. ;; This is how compiled code (including DEFUN) gets its hands on ;; a function. is the XEP lambda for the called - ;; function; its LEAF-INFO should be an ENTRY-INFO structure. + ;; function; its LEAF-INFO should be an ENTRY-INFO structure. ;; ;; (:label .