;;; 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
#!-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.
;;;
(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
#-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
;; 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
#+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)
#+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
;; 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
;;; 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
(#+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)
;; 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
;; 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
;;; 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))
;;; 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
(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
\f
(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
;;;; 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.
;;; 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)
(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))
;;; 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
(/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))))))
\f
;;;; 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)
;;; 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))
#-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
;;; 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."))
(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
;; 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))
;; 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.
#!-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
(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
(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))))
\f
;;;; *INFO-ENVIRONMENT*
(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.
(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))))))))
\f
;;;; definitions for function information
: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
;;; 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.
: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
;; 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
: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
: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
:type-spec t
:default nil)
(define-info-type
- :class :typed-structure
+ :class :typed-structure
:type :documentation
:type-spec (or string null)
:default nil)
: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
(!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))
\f
;;;; a hack for detecting
(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))
(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
(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))
(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
(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
(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
(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
(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.
(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))
(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"
(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)
(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.
(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)))
\f
;;;; ANSI Common Lisp functions which are defined in terms of the info
;;;; database
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))
;; 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))
;; 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)
(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))
;;; 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
(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)
(setf *stepping* nil))
(step-next ()
nil)
- (step-into ()
+ (step-into ()
t))))
(defun step-variable (symbol value)
(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.
#+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*))
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)
(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)
(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)
(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))
(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
(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
(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)
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))))
\f
;;;; translators for compiler-magic special forms
;;; 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))
;;; 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)
(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."
(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)
(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)
(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
(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."))
(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)))))
\f
;;;; QUOTE
(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)))
(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))
;;; 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))))
(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))))
(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
forms
vars
values
- post-binding-lexenv))))
+ post-binding-lexenv))))
(compiler-error "Malformed LET* bindings: ~S." bindings)))
;;; logic shared between IR1 translators for LOCALLY, MACROLET,
(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)
(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
(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:)
""
#-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)
(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.
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
(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))))
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)
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)))))))
\f
;;;; multiple-value stuff
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)
((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)))))
(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 "~@<unable to ~2I~_~A ~I~_because: ~2I~_~?~:>"
- 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 "~@<unable to ~
+ (let ((what (cdr failure))
+ (note (transform-note (car failure))))
+ (cond
+ ((consp what)
+ (compiler-notify "~@<unable to ~2I~_~A ~I~_because: ~2I~_~?~:>"
+ 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 "~@<unable to ~
~2I~_~A ~
~I~_due to type uncertainty: ~
~2I~_~{~?~^~@:_~}~:>"
- 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
;;; 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
"~@<The previously declared FTYPE~2I ~_~S~I ~_~
conflicts with the definition type ~2I~_~S~:>"
(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
;;; 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.
(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)
(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)
(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
;; 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)))))
(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.
(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)
(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))
(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))
(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
(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
(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)
(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)
(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))
(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
(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)
(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
(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
(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
(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))
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
;;; 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
(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.
(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)))))
;;; 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
(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
;;; 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))
(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)))
(() (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) '+))
(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
(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))
(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
(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
(: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))
;;; 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
(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)))
(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
(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:
;;; 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)
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)
(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)))
;;; 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
(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.
(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)))))))))))
\f
;;;; printing error messages
;;; 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.
(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)
(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)
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
(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)))))
\f
;;;; condition system interface
(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)
;;; 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))
(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
;;; 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
;;; 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
(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
;;; 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*)
(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)
(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*))
(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)
;; 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
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
(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)
(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))
;;; 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 '()))
(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
(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
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)
(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))
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)
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))
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"
(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))
(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)
;;; 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))
(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))))
\f
;;;; defining global functions
;;; 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
(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
;;; 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
;; 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
(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
(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))
(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.
(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
;; (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
(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.
(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
(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
(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)))))))
\f
;;; Grovel over CONSTANT checking for any sub-parts that need to be
;;; processed with MAKE-LOAD-FORM. We have to be careful, because
(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))
\f
(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))
(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
(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)))))))
\f
;;;; 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
(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)))
(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
(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)))
(aver (eql (lambda-component functional) *current-component*)))
(pushnew functional
- (component-reanalyze-functionals *current-component*)))
+ (component-reanalyze-functionals *current-component*)))
functional)
(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))
(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
(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)
;;; 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,
(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))))
;;; 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))
\f
;;;; converting combinations
;;; 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)))
(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
(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
(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.
(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))
(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)))
\f
;;;; PROCESS-DECLS
;;; *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.
(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
(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
(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
: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
`(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
;;; 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)
(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
;;; 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))))
(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)))))
;;; 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*
(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)
(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)
;; 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))
(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))
;; 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))
;;; 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
(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)
(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
(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))
(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))
(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)
(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)
(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)
(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))
\f
;;;; deleting stuff
;; 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
;; 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
;;; 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)))
(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))
;; 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))
(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))
(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))
(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)
(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))
(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
(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
(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.
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))
(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))
;;; 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)))
\f
;;; 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
(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))
(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
(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)
(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)
;;; 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)
(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)))))))))))
\f
;;;; careful call
;;; 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
`(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))))))
;;; 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)
(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
(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)))))
\f
;;;; miscellaneous
(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))))
(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
;;; 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))
;;; 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))))
(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
(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))
;; 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.
;;
;; 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
;;; 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))
(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)))
(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
;;; 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)
(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)
(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
(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
;;; 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)
;;; 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)))))
;;; 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
;;; 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
;;; 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
;;; 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))
(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
;;; 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)))))
(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))
(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
(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))
;;; 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
(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))
\f
;;;; full call
(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
(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))
(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
(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.
(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
;;; 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
;; 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
(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))
(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)
(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))
\f
(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
(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
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))
;;; 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
;;; 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)))
(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))
(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))
(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))
;;; 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)))
;;; 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)
(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)))))
\f
;;;; 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*))
(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
(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))
(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))
(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)
;;; 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
;;; 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."
- "~@<overwriting old FUN-INFO ~2I~_~S ~I~_for ~S~:>"
- 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."
+ "~@<overwriting old FUN-INFO ~2I~_~S ~I~_for ~S~:>"
+ 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)
(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)))))
(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
(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)
(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
(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")
(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.
(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))))
;;; 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))
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))
;;; (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 . <function>) (a
(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)
;; 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)))))))
;;; 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))
(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
(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))
(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)
(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))
;;; 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)
(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))
(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
(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))
\f
(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
(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
(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.
(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
(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))))
;;; 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)))
(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
;;; 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))
(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)))
;;; 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.
`(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
'(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
'(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
(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)
(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)
(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))
(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
(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
(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))
(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)))))))))
(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
(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,
(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
(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))))))
\f
;;; Attempt to convert all references to FUN to local calls. The
;;; reference must be the function for a call, and the function lvar
(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)
(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)
(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))
;;; 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)
(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)
(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))
(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))))
(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)))))
\f
;;;; &OPTIONAL, &MORE and &KEYWORD calls
;;; 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
;;; 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)
(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)
(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))
\f
(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)
;; 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.
;; 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
(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)))
(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.
;;; 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)
(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
;;; 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))
(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
;;; 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
;; 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))))
\f
;;;; tail local calls and assignments
(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
(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
;;; 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.
;;;
(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
;;; 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))
(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)))))
(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
;;;
(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))))
(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))))
;;; 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))
(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
(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
(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
;;;
(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))))
;;; 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
(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)
(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
(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))
(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))
(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
(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))
(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))
(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))
(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))
(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
(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))
;;; 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)))
(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))
;;; 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))
;;; 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
;;; 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))))
(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:
(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,
;;; 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
;;; 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))
(: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
;;; 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,
(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 "~@<recursion in known function definition~2I ~
+ (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 "~@<recursion in known function definition~2I ~
~_policy=~S ~_arg types=~S~:>"
- (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))
;;; 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))
(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))))
(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
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)))
;;; 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))
\f
;;;; source-hacking defining forms
;;; 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.)
;;; 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
(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
(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)
;; 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))
;; 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
;;; 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)
(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
\f
;;; 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))))))))
\f
;;;; DEFKNOWN and DEFOPTIMIZER
(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)
(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
;;; 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)))))))
\f
;;;; IR groveling macros
(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.
(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
;;; 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
`(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)
;;; 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)))
;;; 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
(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)
(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
(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
(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)))
(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))
\f
;;;; functions on directly-linked lists (linked through specialized
;;; 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
(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
(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))))
;;; 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
(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.
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
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))
(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?
(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
- "~@<There is no function named ~S. References to ~S in ~
+ (case name
+ ((declare)
+ (compiler-warn
+ "~@<There is no function named ~S. References to ~S in ~
some contexts (like starts of blocks) have special ~
meaning, but here it would have to be a function, ~
and that shouldn't be right.~:@>"
- name name))
- (t
- (compiler-warn
- "~@<The ~(~A~) ~S is undefined, and its name is ~
+ name name))
+ (t
+ (compiler-warn
+ "~@<The ~(~A~) ~S is undefined, and its name is ~
reserved by ANSI CL so that even if it were ~
defined later, the code doing so would not be ~
portable.~:@>"
- 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~]~
~[~:;~:*~& 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*)))
(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*))))
\f
;;;; component compilation
(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)
(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
(loop
(find-dfo component)
(unless (component-reanalyze component)
- (maybe-mumble " ")
- (return))
+ (maybe-mumble " ")
+ (return))
(maybe-mumble ".")))
(values))
(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)
(defun %compile-component (component)
(let ((*code-segment* nil)
- (*elsewhere* nil))
+ (*elsewhere* nil))
(maybe-mumble "GTN ")
(gtn-analyze component)
(maybe-mumble "LTN ")
(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)
(: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)
#|
(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)
(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))
\f
;;;; clearing global data structures
;;; 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
(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*))
(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)
;;; 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
;;; 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
(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.
(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)))))
;;; 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.
(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))))
\f
;;;; processing of top level forms
(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))
(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.
(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,
;;; 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
(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
;;; 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
(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 <x> '(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 <x> '(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)
(%compile lambda-expression
*compile-object*
:name name
- :path path)
+ :path path)
*compile-object*)
(values))
(*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
(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)))
;; (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)
magic
(lambda (&key funs prepend)
(declare (ignore funs))
- (aver (null prepend))
+ (aver (null prepend))
(process-toplevel-locally body
path
compile-time-too))
(funcall-in-symbol-macrolet-lexenv
magic
(lambda (&key vars prepend)
- (aver (null prepend))
+ (aver (null prepend))
(process-toplevel-locally body
path
compile-time-too
(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.
(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)))
(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)
(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)
(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)))
(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).
(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)
(*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.
;;; 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)
(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
(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.
: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)))
\f
;;; a helper function for COMPILE-FILE-PATHNAME: the default for
;;; the OUTPUT-FILE argument
;;; 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
;;; 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."
(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))))))))))))
\f
;;;; Host compile time definitions
(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)))
;;; 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))
(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)))
\f
;;; 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
`(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*
(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))))))))))))
\f
;;;; 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
(/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)
;;; 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
(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))))))
\f
;;;; VOP definition structures
;;;;
;;; 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.
;;; 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))
;;; 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
(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
(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
(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)))
\f
;;;; time specs
(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)))))
\f
;;;; 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
(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
;;; 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
;;; 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))))))
\f
(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
;;; 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))))
\f
;;; 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))
(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))
\f
(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
(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)))
\f
;;;; making costs and restrictions
(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)))
(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)))))
\f
;;;; operand checking and stuff
(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
(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))
;;; 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))
(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))
\f
(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)
;;; 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)))))
\f
;;;; setting up VOP-INFO
(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)
,@(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))))
\f
;;; Define the symbol NAME to be a Virtual OPeration in the compiler.
;;; 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}
;; 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)
`(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)))
\f
;;;; emission macros
;;; 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))))
;;; 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*
;;;
;;; 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*
;;;
(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))))))
\f
;;;; miscellaneous macros
;;; 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))
;;; 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)))))
;;; "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))
;;; 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
(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
(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
;;; 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)
;;; 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:
(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)
(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))
;; 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
;;; 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
;;; 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)
(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
(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.
;;; 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
;;; 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.)
;; 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:
;;; 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))
;;; 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))
(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
;;; 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)
;;; 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.
;;
;; %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
;;; 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)
;;;
;;; 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
;; 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.
;;; 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)
;;; 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,
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
;;; 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
;;; 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)
- "<deleted>"))
- args)))
+ (if x
+ (lvar-uses x)
+ "<deleted>"))
+ 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)))
;;; 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)))
;;; 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))
;;; 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
;;; 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.
;;; 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
;;;; 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
;;; 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))))
#!-sb-fluid
(declaim (freeze-type node leaf lexenv ctran lvar cblock component cleanup
- physenv tail-set nlx-info))
+ physenv tail-set nlx-info))
(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)
(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
(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
(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)
(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
(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))
;;; 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
(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)))
((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))
(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:~:{~%~@?~}~%~;~
~:[~;~@
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:~
~:[~;~@
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))))
\f
;;;; register saving
(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
;;; 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.
(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))))
(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)))
(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
((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))
\f
(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.
(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)
;;; 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))))
(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
(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
(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))))))))))
\f
;;;; load TN packing
(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))
(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))
(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
;;; 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
(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
(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)
(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))))
(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)
(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
(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))
(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))
\f
;;;; targeting
(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
(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))))
\f
;;;; location selection
(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.
(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,
(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
;; 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
;; 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)))
(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)))
(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)
(more-context nil)
(more-count nil)
(keyp nil)
- (auxp nil)
+ (auxp nil)
(allowp nil)
(state :required))
(declare (type (member :allow-other-keys :aux
(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
(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"))
;; 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")
;;; 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.
;;; 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)
(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)
(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
(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
(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.
;;; 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
;; 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)
(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)
(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))
(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)))
(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))
\f
;;;; final decision on stack allocation of dynamic-extent structures
(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))
(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
;; 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))
(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
;;; 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
;;; 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
;;; 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))
,(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*)))
(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
;; 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)
(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
#+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)))
~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))
(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.
(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
(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~%~]~
~:[~;~@
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))))
\f
;;;; VM consistency checking
;;;;
(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)))))))))
\f
;;;; representation selection
;;; 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
;;; 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
(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))
(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))))
- "<return value>")
- (t
- nil))))
+ ((and (not arg-p) reads
+ (return-p (vop-node (tn-ref-vop reads))))
+ "<return value>")
+ (t
+ nil))))
;;; If policy indicates, give an efficiency note for doing the
;;; coercion VOP, where OP is the operand we are coercing for and
(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
;;; 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,
;;; 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
#!-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))
(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
;;; 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
(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,
(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))
;;; 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)))
(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))
(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
())
\f
;;;; transforms for converting sap relation operators
(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) * *)
#!+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)
(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)
;;; 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,
(declare (type list seqs seq-names)
(type symbol into))
(collect ((bindings)
- (declarations)
+ (declarations)
(vector-lengths)
(tests)
(places))
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))
;;; 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))
'(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))
(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))))))
(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
(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
;;; 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)
(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
(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))
;;; 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
#!+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
`(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)))
|#
(- start2
start1))))))
index)
- (t nil))
+ (t nil))
,(if ',equalp 'end1 nil))))))
(def string<* t nil)
(def string<=* t t)
;;; * :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
;;; 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")
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)))
(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)))))
\f
;;;; FIND, POSITION, and their -IF and -IF-NOT variants
(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))
;;; 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
`(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
`(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
;;; %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"))
(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))
;;; 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))
(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
(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.")))))
(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
;; 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
(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))))
\f
;;;; arithmetic and numerology
;;; 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.)
(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))))))
(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)))
\f
;;;; interval arithmetic for computing bounds
;;;;
;;; 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-= =)
;;; 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.
(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
(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))
(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
;;; 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.
;;; 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
(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))
(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.
(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.
;; 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)
(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
(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
;; 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.
(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].
(defun interval-sqr (x)
(declare (type interval x))
(interval-func (lambda (x) (* x x))
- (interval-abs x)))
+ (interval-abs x)))
\f
;;;; numeric DERIVE-TYPE methods
(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)))
;;; 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
;;; 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))
;;; 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))
(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))
;;; 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)
(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))
;;; 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
;;; 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)))))))
\f
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
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)))
(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)))
(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)))
(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))
(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))
;; 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)))
(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))
#+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
;; 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)))))
;; 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)))))
(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))))
(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))
;; 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
(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
(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)
;; 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
(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
(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))
;; 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
(+
(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:
;;; 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)
(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
;; 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))
(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
(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))
(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))
(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))
\f
;;;; miscellaneous derive-type methods
(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))
;;;; 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)
(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))
(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)
(%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))
;;; (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*)))
\f
;;; Modular functions
;;; 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) * *)
(#.sb!xc:boole-orc2 '(logorc2 x y))
(t
(abort-ir1-transform "~S is an illegal control arg to BOOLE."
- control)))))
+ control)))))
\f
;;;; converting special case multiply/divide to shifts
(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))
(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))
(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) *)
(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)))))
\f
;;;; arithmetic and logical identity operation elimination
(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
(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).
;;;
"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)
"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)
;; 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?
(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))))))))
(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)))
\f
;;;; equality predicate transforms
(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)
(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)
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
(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)))))
(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.
;; 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))))
(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))
(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))
(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)))))
\f
;;;; converting N-arg arithmetic functions
;;;;
(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)))))
(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))))))
\f
;;;; transforming FORMAT
(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))))
(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))
(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
(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
;; 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
;; 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
`(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
;; 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))))))
\f
;;;; debuggers' little helpers
;;; (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,
;;; 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))
(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.
(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))
;;; 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
(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))))))
;;; 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)))
(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))))
(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)
(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))
(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...
;;;
(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)))))
\f
;;;; choosing an instruction
;;; 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
;;; 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))
\f
;;;; searching for an instruction in instruction space
;;; 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)))))))))
\f
;;;; building the instruction space
;; 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))))))))))
\f
;;;; an inst-space printer for debugging purposes
(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))
(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))
(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)))))
\f
;;;; (The actual disassembly part follows.)
\f
;;; 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
-;;; ...
-;;; <padding to dual-word boundary>
-;;; start of instructions
-;;; ...
-;;; fun-headers and lra's buried in here randomly
-;;; ...
-;;; start of trace-table
-;;; <padding to dual-word boundary>
+;;; 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
+;;; ...
+;;; <padding to dual-word boundary>
+;;; start of instructions
+;;; ...
+;;; fun-headers and lra's buried in here randomly
+;;; ...
+;;; start of trace-table
+;;; <padding to dual-word boundary>
;;;
;;; 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))
(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))
(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)))))
\f
;;;; function ops
(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)
(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))))
\f
(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)
;;; 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)))
\f
(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)))
;;; 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)))))
\f
;;; Make an initial non-printing disassembly pass through DSTATE,
;;; noting any addresses that are referenced by instructions in this
(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)
;; 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))))
\f
;;; Get the instruction-space, creating it if necessary.
(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))
\f
(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)))
\f
(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))
;; 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)
(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
;;; 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)))
;;; 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)))))
\f
(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))))))
\f
;;; A SAP-MAKER is a no-argument function that returns a SAP.
(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)))
\f
;;; 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))
\f
;;; 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)))))))
\f
;;; 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)
(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)))
\f
(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.
;;; 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))
(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
;;; 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)))))))))
\f
;;; 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))))
\f
;;; 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
;;; 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
;;; 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)))
;;; 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)))))
\f
;;;; 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)))
(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
;;; 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)))
;;; 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)))
(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))))))))
\f
;;;; 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)))
\f
;;; 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
(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))
(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))
(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
;;; 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)
(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*))
\f
;;;; some handy function for machine-dependent code to use...
(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))))
\f
;;;; optional routines to make notes about code
;;; 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)
;;; 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
;;; 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
;;; 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
;;; 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
(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
;;; 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
;;; 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)))
\f
(defun get-internal-error-name (errnum)
;; 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
;;; 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)))
(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)))
(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)))
(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
(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
(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*)
;; 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),
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)))
(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))))
\f
(defun set-ir2-physenv-live-tns (value instance)
(setf (ir2-physenv-live-tns instance) value))
;;; 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))
\f
;;;; TN creation
(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))
(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))
;;; 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))
(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))
(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.
(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
(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))
(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.
(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))
(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
(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.
;;; 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)))
(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)
;;; 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.
(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))
(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)
(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))
(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))
\f
(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))
;;; 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)))
;;; 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))))
\f
;;;; standard type predicates, i.e. those defined in package COMMON-LISP,
;;;; plus at least one oddball (%INSTANCEP)
(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
;;; 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
(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))
(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)
(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
(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
(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.
(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
(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))
((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
;;; 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
;; 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)))
\f
;;;; coercion
(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)))))))
(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))))
(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))))
\f
(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))))))))
\f
;;;; primitive type definition
(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.
(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))))))
\f
;;;; generation of emit functions
(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))))
\f
;;;; function translation stuff
(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))
\f
;;; 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))))))
;;;
;;; 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
;;; 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))
;; 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))
;;; 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
;; Is replaced by the code pointer for the specified function.
;; This is how compiled code (including DEFUN) gets its hands on
;; a function. <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 . <label>)
;; Is replaced with the byte offset of that label from the start
(save-sp (missing-arg) :type tn)
;; the list of dynamic state save TNs
(dynamic-state (list* (make-stack-pointer-tn)
- (make-dynamic-state-tns))
- :type list)
+ (make-dynamic-state-tns))
+ :type list)
;; the target label for NLX entry
(target (gen-label) :type label))
(defprinter (ir2-nlx-info)
dynamic-state)
(defstruct (cloop (:conc-name loop-)
- (:predicate loop-p)
- (:constructor make-loop)
- (:copier copy-loop))
+ (:predicate loop-p)
+ (:constructor make-loop)
+ (:copier copy-loop))
;; The kind of loop that this is. These values are legal:
;;
;; :OUTER
;;; A VOP is a Virtual Operation. It represents an operation and the
;;; operands to the operation.
(def!struct (vop (:constructor make-vop (block node info args results))
- (:copier nil))
+ (:copier nil))
;; VOP-INFO structure containing static info about the operation
(info nil :type (or vop-info null))
;; the IR2-BLOCK this VOP is in
;;; to a TN. The information in TN-REFs largely determines how TNs are
;;; packed.
(def!struct (tn-ref (:constructor make-tn-ref (tn write-p))
- (:copier nil))
+ (:copier nil))
;; the TN referenced
(tn (missing-arg) :type tn)
;; Is this is a write reference? (as opposed to a read reference)
;;; A TEMPLATE object represents a particular IR2 coding strategy for
;;; a known function.
(def!struct (template (:constructor nil)
- #-sb-xc-host (:pure t))
+ #-sb-xc-host (:pure t))
;; the symbol name of this VOP. This is used when printing the VOP
;; and is also used to provide a handle for definition and
;; translation.
;; lists of restrictions on the argument and result types. A
;; restriction may take several forms:
;; -- The restriction * is no restriction at all.
- ;; -- A restriction (:OR <primitive-type>*) means that the operand
+ ;; -- A restriction (:OR <primitive-type>*) means that the operand
;; must have one of the specified primitive types.
;; -- A restriction (:CONSTANT <predicate> <type-spec>) means that the
;; argument (not a result) must be a compile-time constant that
;;; virtual operation. We include TEMPLATE so that functions with a
;;; direct VOP equivalent can be translated easily.
(def!struct (vop-info
- (:include template)
- (:make-load-form-fun ignore-it))
+ (:include template)
+ (:make-load-form-fun ignore-it))
;; side effects of this VOP and side effects that affect the value
;; of this VOP
(effects (missing-arg) :type attributes)
;; then the entries are NIL. LOAD-COSTS is initialized to have a 0
;; for this SC.
(move-funs (make-array sc-number-limit :initial-element nil)
- :type sc-vector)
+ :type sc-vector)
(load-costs (make-array sc-number-limit :initial-element nil)
- :type sc-vector)
+ :type sc-vector)
;; a vector mapping from SC numbers to possibly
;; representation-specific move and coerce VOPs. Each entry is a
;; list of VOP-INFOs for VOPs that move/coerce an object in the
;; already be live TNs wired in those locations holding the values
;; that we are setting up for unknown-values return.
(move-vops (make-array sc-number-limit :initial-element nil)
- :type sc-vector)
+ :type sc-vector)
;; the costs corresponding to the MOVE-VOPS. Separate because this
;; info is needed at meta-compile time, while the MOVE-VOPs don't
;; exist till load time. If no move is defined, then the entry is
;; NIL.
(move-costs (make-array sc-number-limit :initial-element nil)
- :type sc-vector)
+ :type sc-vector)
;; similar to Move-VOPs, except that we only ever use the entries
;; for this SC and its alternates, since we never combine complex
;; representation conversion with argument passing.
(move-arg-vops (make-array sc-number-limit :initial-element nil)
- :type sc-vector)
+ :type sc-vector)
;; true if this SC or one of its alternates in in the NUMBER-STACK SB.
(number-stack-p nil :type boolean)
;; alignment restriction. The offset must be an even multiple of this.
;;;; TNs
(def!struct (tn (:include sset-element)
- (:constructor make-random-tn)
- (:constructor make-tn (number kind primitive-type sc))
- (:copier nil))
+ (:constructor make-random-tn)
+ (:constructor make-tn (number kind primitive-type sc))
+ (:copier nil))
;; The kind of TN this is:
;;
;; :NORMAL
- ;; A normal, non-constant TN, representing a variable or temporary.
- ;; Lifetime information is computed so that packing can be done.
+ ;; A normal, non-constant TN, representing a variable or temporary.
+ ;; Lifetime information is computed so that packing can be done.
;;
;; :ENVIRONMENT
- ;; A TN that has hidden references (debugger or NLX), and thus must be
- ;; allocated for the duration of the environment it is referenced in.
+ ;; A TN that has hidden references (debugger or NLX), and thus must be
+ ;; allocated for the duration of the environment it is referenced in.
;;
;; :DEBUG-ENVIRONMENT
- ;; Like :ENVIRONMENT, but is used for TNs that we want to be able to
- ;; target to/from and that don't absolutely have to be live
- ;; everywhere. These TNs are live in all blocks in the environment
- ;; that don't reference this TN.
+ ;; Like :ENVIRONMENT, but is used for TNs that we want to be able to
+ ;; target to/from and that don't absolutely have to be live
+ ;; everywhere. These TNs are live in all blocks in the environment
+ ;; that don't reference this TN.
;;
;; :COMPONENT
- ;; A TN that implicitly conflicts with all other TNs. No conflict
- ;; info is computed.
+ ;; A TN that implicitly conflicts with all other TNs. No conflict
+ ;; info is computed.
;;
;; :SAVE
;; :SAVE-ONCE
- ;; A TN used for saving a :NORMAL TN across function calls. The
- ;; lifetime information slots are unitialized: get the original
- ;; TN our of the SAVE-TN slot and use it for conflicts. SAVE-ONCE
- ;; is like :SAVE, except that it is only save once at the single
- ;; writer of the original TN.
+ ;; A TN used for saving a :NORMAL TN across function calls. The
+ ;; lifetime information slots are unitialized: get the original
+ ;; TN our of the SAVE-TN slot and use it for conflicts. SAVE-ONCE
+ ;; is like :SAVE, except that it is only save once at the single
+ ;; writer of the original TN.
;;
;; :SPECIFIED-SAVE
- ;; A TN that was explicitly specified as the save TN for another TN.
- ;; When we actually get around to doing the saving, this will be
- ;; changed to :SAVE or :SAVE-ONCE.
+ ;; A TN that was explicitly specified as the save TN for another TN.
+ ;; When we actually get around to doing the saving, this will be
+ ;; changed to :SAVE or :SAVE-ONCE.
;;
;; :LOAD
- ;; A load-TN used to compute an argument or result that is
- ;; restricted to some finite SB. Load TNs don't have any conflict
- ;; information. Load TN pack uses a special local conflict
- ;; determination method.
+ ;; A load-TN used to compute an argument or result that is
+ ;; restricted to some finite SB. Load TNs don't have any conflict
+ ;; information. Load TN pack uses a special local conflict
+ ;; determination method.
;;
;; :CONSTANT
- ;; Represents a constant, with TN-LEAF a CONSTANT leaf. Lifetime
- ;; information isn't computed, since the value isn't allocated by
- ;; pack, but is instead generated as a load at each use. Since
- ;; lifetime analysis isn't done on :CONSTANT TNs, they don't have
- ;; LOCAL-NUMBERs and similar stuff.
+ ;; Represents a constant, with TN-LEAF a CONSTANT leaf. Lifetime
+ ;; information isn't computed, since the value isn't allocated by
+ ;; pack, but is instead generated as a load at each use. Since
+ ;; lifetime analysis isn't done on :CONSTANT TNs, they don't have
+ ;; LOCAL-NUMBERs and similar stuff.
;;
;; :ALIAS
- ;; A special kind of TN used to represent initialization of local
- ;; call arguments in the caller. It provides another name for the
- ;; argument TN so that lifetime analysis doesn't get confused by
- ;; self-recursive calls. Lifetime analysis treats this the same
- ;; as :NORMAL, but then at the end merges the conflict info into
- ;; the original TN and replaces all uses of the alias with the
- ;; original TN. SAVE-TN holds the aliased TN.
+ ;; A special kind of TN used to represent initialization of local
+ ;; call arguments in the caller. It provides another name for the
+ ;; argument TN so that lifetime analysis doesn't get confused by
+ ;; self-recursive calls. Lifetime analysis treats this the same
+ ;; as :NORMAL, but then at the end merges the conflict info into
+ ;; the original TN and replaces all uses of the alias with the
+ ;; original TN. SAVE-TN holds the aliased TN.
(kind (missing-arg)
- :type (member :normal :environment :debug-environment
- :save :save-once :specified-save :load :constant
- :component :alias))
+ :type (member :normal :environment :debug-environment
+ :save :save-once :specified-save :load :constant
+ :component :alias))
;; the primitive-type for this TN's value. Null in restricted or
;; wired TNs.
(primitive-type nil :type (or primitive-type null))
;; If this object is a local TN, this slot is a bit-vector with 1
;; for the local-number of every TN that we conflict with.
(local-conflicts (make-array local-tn-limit
- :element-type 'bit
- :initial-element 0)
- :type local-tn-bit-vector)
+ :element-type 'bit
+ :initial-element 0)
+ :type local-tn-bit-vector)
;; head of the list of GLOBAL-CONFLICTS structures for a global TN.
;; This list is sorted by block number (i.e. reverse DFO), allowing
;; the intersection between the lifetimes for two global TNs to be
;;; lifetime analysis to represent the set of TNs live at the start of
;;; the IR2 block.
(defstruct (global-conflicts
- (:constructor make-global-conflicts (kind tn block number))
- (:copier nil))
+ (:constructor make-global-conflicts (kind tn block number))
+ (:copier nil))
;; the IR2-BLOCK that this structure represents the conflicts for
(block (missing-arg) :type ir2-block)
;; thread running through all the GLOBAL-CONFLICTSs for BLOCK. This
;; the way that TN is used by BLOCK
;;
;; :READ
- ;; The TN is read before it is written. It starts the block live,
- ;; but is written within the block.
+ ;; The TN is read before it is written. It starts the block live,
+ ;; but is written within the block.
;;
;; :WRITE
- ;; The TN is written before any read. It starts the block dead,
- ;; and need not have a read within the block.
+ ;; The TN is written before any read. It starts the block dead,
+ ;; and need not have a read within the block.
;;
;; :READ-ONLY
- ;; The TN is read, but never written. It starts the block live,
- ;; and is not killed by the block. Lifetime analysis will promote
- ;; :READ-ONLY TNs to :LIVE if they are live at the block end.
+ ;; The TN is read, but never written. It starts the block live,
+ ;; and is not killed by the block. Lifetime analysis will promote
+ ;; :READ-ONLY TNs to :LIVE if they are live at the block end.
;;
;; :LIVE
- ;; The TN is not referenced. It is live everywhere in the block.
+ ;; The TN is not referenced. It is live everywhere in the block.
(kind :read-only :type (member :read :write :read-only :live))
;; a local conflicts vector representing conflicts with TNs live in
;; BLOCK. The index for the local TN number of each TN we conflict
;; TNs for BLOCK must also be included. This slot is not meaningful
;; when KIND is :LIVE.
(conflicts (make-array local-tn-limit
- :element-type 'bit
- :initial-element 0)
- :type local-tn-bit-vector)
+ :element-type 'bit
+ :initial-element 0)
+ :type local-tn-bit-vector)
;; the TN we are recording conflicts for.
(tn (missing-arg) :type tn)
;; thread through all the GLOBAL-CONFLICTSs for TN
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.2.46"
+"0.9.2.47"
projects / sbcl.git / commitdiff