;;;; cosmetic transforms
(deftransform slot ((object slot)
- ((alien (* t)) symbol))
+ ((alien (* t)) symbol))
'(slot (deref object) slot))
(deftransform %set-slot ((object slot value)
- ((alien (* t)) symbol t))
+ ((alien (* t)) symbol t))
'(%set-slot (deref object) slot value))
(deftransform %slot-addr ((object slot)
- ((alien (* t)) symbol))
+ ((alien (* t)) symbol))
'(%slot-addr (deref object) slot))
\f
;;;; SLOT support
(give-up-ir1-transform))
(let ((alien-type (alien-type-type-alien-type type)))
(unless (alien-record-type-p alien-type)
- (give-up-ir1-transform))
+ (give-up-ir1-transform))
(let* ((slot-name (lvar-value slot))
- (field (find slot-name (alien-record-type-fields alien-type)
- :key #'alien-record-field-name)))
- (unless field
- (abort-ir1-transform "~S doesn't have a slot named ~S"
- alien
- slot-name))
- (values (alien-record-field-offset field)
- (alien-record-field-type field))))))
+ (field (find slot-name (alien-record-type-fields alien-type)
+ :key #'alien-record-field-name)))
+ (unless field
+ (abort-ir1-transform "~S doesn't have a slot named ~S"
+ alien
+ slot-name))
+ (values (alien-record-field-offset field)
+ (alien-record-field-type field))))))
#+nil ;; Shouldn't be necessary.
(defoptimizer (slot derive-type) ((alien slot))
(block nil
(catch 'give-up-ir1-transform
(multiple-value-bind (slot-offset slot-type)
- (find-slot-offset-and-type alien slot)
- (declare (ignore slot-offset))
- (return (make-alien-type-type slot-type))))
+ (find-slot-offset-and-type alien slot)
+ (declare (ignore slot-offset))
+ (return (make-alien-type-type slot-type))))
*wild-type*))
(deftransform slot ((alien slot) * * :important t)
(multiple-value-bind (slot-offset slot-type)
(find-slot-offset-and-type alien slot)
`(extract-alien-value (alien-sap alien)
- ,slot-offset
- ',slot-type)))
+ ,slot-offset
+ ',slot-type)))
#+nil ;; ### But what about coercions?
(defoptimizer (%set-slot derive-type) ((alien slot value))
(block nil
(catch 'give-up-ir1-transform
(multiple-value-bind (slot-offset slot-type)
- (find-slot-offset-and-type alien slot)
- (declare (ignore slot-offset))
- (let ((type (make-alien-type-type slot-type)))
- (assert-lvar-type value type)
- (return type))))
+ (find-slot-offset-and-type alien slot)
+ (declare (ignore slot-offset))
+ (let ((type (make-alien-type-type slot-type)))
+ (assert-lvar-type value type)
+ (return type))))
*wild-type*))
(deftransform %set-slot ((alien slot value) * * :important t)
(multiple-value-bind (slot-offset slot-type)
(find-slot-offset-and-type alien slot)
`(deposit-alien-value (alien-sap alien)
- ,slot-offset
- ',slot-type
- value)))
+ ,slot-offset
+ ',slot-type
+ value)))
(defoptimizer (%slot-addr derive-type) ((alien slot))
(block nil
(catch 'give-up-ir1-transform
(multiple-value-bind (slot-offset slot-type)
- (find-slot-offset-and-type alien slot)
- (declare (ignore slot-offset))
- (return (make-alien-type-type
- (make-alien-pointer-type :to slot-type)))))
+ (find-slot-offset-and-type alien slot)
+ (declare (ignore slot-offset))
+ (return (make-alien-type-type
+ (make-alien-pointer-type :to slot-type)))))
*wild-type*))
(deftransform %slot-addr ((alien slot) * * :important t)
(find-slot-offset-and-type alien slot)
(/noshow "in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
`(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset sb!vm:n-byte-bits))
- ',(make-alien-pointer-type :to slot-type))))
+ ',(make-alien-pointer-type :to slot-type))))
\f
;;;; DEREF support
(give-up-ir1-transform))
(let ((alien-type (alien-type-type-alien-type alien-type)))
(if (alien-type-p alien-type)
- alien-type
- (give-up-ir1-transform)))))
+ alien-type
+ (give-up-ir1-transform)))))
(defun find-deref-element-type (alien)
(let ((alien-type (find-deref-alien-type alien)))
(typecase alien-type
(alien-pointer-type
(when (cdr indices)
- (abort-ir1-transform "too many indices for pointer deref: ~W"
- (length indices)))
+ (abort-ir1-transform "too many indices for pointer deref: ~W"
+ (length indices)))
(let ((element-type (alien-pointer-type-to alien-type)))
- (if indices
- (let ((bits (alien-type-bits element-type))
- (alignment (alien-type-alignment element-type)))
- (unless bits
- (abort-ir1-transform "unknown element size"))
- (unless alignment
- (abort-ir1-transform "unknown element alignment"))
- (values '(offset)
- `(* offset
- ,(align-offset bits alignment))
- element-type))
- (values nil 0 element-type))))
+ (if indices
+ (let ((bits (alien-type-bits element-type))
+ (alignment (alien-type-alignment element-type)))
+ (unless bits
+ (abort-ir1-transform "unknown element size"))
+ (unless alignment
+ (abort-ir1-transform "unknown element alignment"))
+ (values '(offset)
+ `(* offset
+ ,(align-offset bits alignment))
+ element-type))
+ (values nil 0 element-type))))
(alien-array-type
(let* ((element-type (alien-array-type-element-type alien-type))
- (bits (alien-type-bits element-type))
- (alignment (alien-type-alignment element-type))
- (dims (alien-array-type-dimensions alien-type)))
- (unless (= (length indices) (length dims))
- (give-up-ir1-transform "incorrect number of indices"))
- (unless bits
- (give-up-ir1-transform "Element size is unknown."))
- (unless alignment
- (give-up-ir1-transform "Element alignment is unknown."))
- (if (null dims)
- (values nil 0 element-type)
- (let* ((arg (gensym))
- (args (list arg))
- (offsetexpr arg))
- (dolist (dim (cdr dims))
- (let ((arg (gensym)))
- (push arg args)
- (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
- (values (reverse args)
- `(* ,offsetexpr
- ,(align-offset bits alignment))
- element-type)))))
+ (bits (alien-type-bits element-type))
+ (alignment (alien-type-alignment element-type))
+ (dims (alien-array-type-dimensions alien-type)))
+ (unless (= (length indices) (length dims))
+ (give-up-ir1-transform "incorrect number of indices"))
+ (unless bits
+ (give-up-ir1-transform "Element size is unknown."))
+ (unless alignment
+ (give-up-ir1-transform "Element alignment is unknown."))
+ (if (null dims)
+ (values nil 0 element-type)
+ (let* ((arg (gensym))
+ (args (list arg))
+ (offsetexpr arg))
+ (dolist (dim (cdr dims))
+ (let ((arg (gensym)))
+ (push arg args)
+ (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
+ (values (reverse args)
+ `(* ,offsetexpr
+ ,(align-offset bits alignment))
+ element-type)))))
(t
(abort-ir1-transform "~S not either a pointer or array type."
- alien-type)))))
+ alien-type)))))
#+nil ;; Shouldn't be necessary.
(defoptimizer (deref derive-type) ((alien &rest noise))
(compute-deref-guts alien indices)
`(lambda (alien ,@indices-args)
(extract-alien-value (alien-sap alien)
- ,offset-expr
- ',element-type))))
+ ,offset-expr
+ ',element-type))))
#+nil ;; ### Again, the value might be coerced.
(defoptimizer (%set-deref derive-type) ((alien value &rest noise))
(block nil
(catch 'give-up-ir1-transform
(let ((type (make-alien-type-type
- (make-alien-pointer-type
- :to (find-deref-element-type alien)))))
- (assert-lvar-type value type)
- (return type)))
+ (make-alien-pointer-type
+ :to (find-deref-element-type alien)))))
+ (assert-lvar-type value type)
+ (return type)))
*wild-type*))
(deftransform %set-deref ((alien value &rest indices) * * :important t)
(compute-deref-guts alien indices)
`(lambda (alien value ,@indices-args)
(deposit-alien-value (alien-sap alien)
- ,offset-expr
- ',element-type
- value))))
+ ,offset-expr
+ ',element-type
+ value))))
(defoptimizer (%deref-addr derive-type) ((alien &rest noise))
(declare (ignore noise))
(block nil
(catch 'give-up-ir1-transform
(return (make-alien-type-type
- (make-alien-pointer-type
- :to (find-deref-element-type alien)))))
+ (make-alien-pointer-type
+ :to (find-deref-element-type alien)))))
*wild-type*))
(deftransform %deref-addr ((alien &rest indices) * * :important t)
(/noshow "in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
`(lambda (alien ,@indices-args)
(%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr sb!vm:n-byte-bits))
- ',(make-alien-pointer-type :to element-type)))))
+ ',(make-alien-pointer-type :to element-type)))))
\f
;;;; support for aliens on the heap
(give-up-ir1-transform "info not constant; can't open code"))
(let ((info (lvar-value info)))
(values (heap-alien-info-sap-form info)
- (heap-alien-info-type info))))
+ (heap-alien-info-type info))))
#+nil ; shouldn't be necessary
(defoptimizer (%heap-alien derive-type) ((info))
(block nil
(catch 'give-up
(multiple-value-bind (sap type) (heap-alien-sap-and-type info)
- (declare (ignore sap))
- (return (make-alien-type-type type))))
+ (declare (ignore sap))
+ (return (make-alien-type-type type))))
*wild-type*))
(deftransform %heap-alien ((info) * * :important t)
(block nil
(catch 'give-up-ir1-transform
(multiple-value-bind (sap type) (heap-alien-sap-and-type info)
- (declare (ignore sap))
- (let ((type (make-alien-type-type type)))
- (assert-lvar-type value type)
- (return type))))
+ (declare (ignore sap))
+ (let ((type (make-alien-type-type type)))
+ (assert-lvar-type value type)
+ (return type))))
*wild-type*))
(deftransform %set-heap-alien ((info value) (heap-alien-info *) * :important t)
(block nil
(catch 'give-up-ir1-transform
(multiple-value-bind (sap type) (heap-alien-sap-and-type info)
- (declare (ignore sap))
- (return (make-alien-type-type (make-alien-pointer-type :to type)))))
+ (declare (ignore sap))
+ (return (make-alien-type-type (make-alien-pointer-type :to type)))))
*wild-type*))
(deftransform %heap-alien-addr ((info) * * :important t)
(unless (constant-lvar-p info)
(abort-ir1-transform "Local alien info isn't constant?"))
(let* ((info (lvar-value info))
- (alien-type (local-alien-info-type info))
- (bits (alien-type-bits alien-type)))
+ (alien-type (local-alien-info-type info))
+ (bits (alien-type-bits alien-type)))
(unless bits
(abort-ir1-transform "unknown size: ~S" (unparse-alien-type alien-type)))
(/noshow "in DEFTRANSFORM MAKE-LOCAL-ALIEN" info)
(/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
(if (local-alien-info-force-to-memory-p info)
#!+(or x86 x86-64) `(truly-the system-area-pointer
- (%primitive alloc-alien-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits)))
+ (%primitive alloc-alien-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits)))
#!-(or x86 x86-64) `(truly-the system-area-pointer
- (%primitive alloc-number-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits)))
+ (%primitive alloc-number-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits)))
(let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
- (alien-rep-type (specifier-type alien-rep-type-spec)))
- (cond ((csubtypep (specifier-type 'system-area-pointer)
- alien-rep-type)
- '(int-sap 0))
- ((ctypep 0 alien-rep-type) 0)
- ((ctypep 0.0f0 alien-rep-type) 0.0f0)
- ((ctypep 0.0d0 alien-rep-type) 0.0d0)
- (t
- (compiler-error
- "Aliens of type ~S cannot be represented immediately."
- (unparse-alien-type alien-type))))))))
+ (alien-rep-type (specifier-type alien-rep-type-spec)))
+ (cond ((csubtypep (specifier-type 'system-area-pointer)
+ alien-rep-type)
+ '(int-sap 0))
+ ((ctypep 0 alien-rep-type) 0)
+ ((ctypep 0.0f0 alien-rep-type) 0.0f0)
+ ((ctypep 0.0d0 alien-rep-type) 0.0d0)
+ (t
+ (compiler-error
+ "Aliens of type ~S cannot be represented immediately."
+ (unparse-alien-type alien-type))))))))
(deftransform note-local-alien-type ((info var) * * :important t)
;; FIXME: This test and error occur about a zillion times. They
(/noshow (local-alien-info-force-to-memory-p info))
(unless (local-alien-info-force-to-memory-p info)
(let ((var-node (lvar-uses var)))
- (/noshow var-node (ref-p var-node))
- (when (ref-p var-node)
- (propagate-to-refs (ref-leaf var-node)
- (specifier-type
- (compute-alien-rep-type
- (local-alien-info-type info))))))))
+ (/noshow var-node (ref-p var-node))
+ (when (ref-p var-node)
+ (propagate-to-refs (ref-leaf var-node)
+ (specifier-type
+ (compute-alien-rep-type
+ (local-alien-info-type info))))))))
nil)
(deftransform local-alien ((info var) * * :important t)
(unless (constant-lvar-p info)
(abort-ir1-transform "Local alien info isn't constant?"))
(let* ((info (lvar-value info))
- (alien-type (local-alien-info-type info)))
+ (alien-type (local-alien-info-type info)))
(/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type)
(/noshow (local-alien-info-force-to-memory-p info))
(if (local-alien-info-force-to-memory-p info)
- `(extract-alien-value var 0 ',alien-type)
- `(naturalize var ',alien-type))))
+ `(extract-alien-value var 0 ',alien-type)
+ `(naturalize var ',alien-type))))
(deftransform %local-alien-forced-to-memory-p ((info) * * :important t)
(unless (constant-lvar-p info)
(unless (constant-lvar-p info)
(abort-ir1-transform "Local alien info isn't constant?"))
(let* ((info (lvar-value info))
- (alien-type (local-alien-info-type info)))
+ (alien-type (local-alien-info-type info)))
(if (local-alien-info-force-to-memory-p info)
- `(deposit-alien-value var 0 ',alien-type value)
- '(error "This should be eliminated as dead code."))))
+ `(deposit-alien-value var 0 ',alien-type value)
+ '(error "This should be eliminated as dead code."))))
(defoptimizer (%local-alien-addr derive-type) ((info var))
(if (constant-lvar-p info)
(let* ((info (lvar-value info))
- (alien-type (local-alien-info-type info)))
- (make-alien-type-type (make-alien-pointer-type :to alien-type)))
+ (alien-type (local-alien-info-type info)))
+ (make-alien-type-type (make-alien-pointer-type :to alien-type)))
*wild-type*))
(deftransform %local-alien-addr ((info var) * * :important t)
(unless (constant-lvar-p info)
(abort-ir1-transform "Local alien info isn't constant?"))
(let* ((info (lvar-value info))
- (alien-type (local-alien-info-type info)))
+ (alien-type (local-alien-info-type info)))
(/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
(if (local-alien-info-force-to-memory-p info)
- `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
- (error "This shouldn't happen."))))
+ `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
+ (error "This shouldn't happen."))))
(deftransform dispose-local-alien ((info var) * * :important t)
(unless (constant-lvar-p info)
(abort-ir1-transform "Local alien info isn't constant?"))
(let* ((info (lvar-value info))
- (alien-type (local-alien-info-type info)))
+ (alien-type (local-alien-info-type info)))
(if (local-alien-info-force-to-memory-p info)
#!+(or x86 x86-64) `(%primitive dealloc-alien-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits))
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits))
#!-(or x86 x86-64) `(%primitive dealloc-number-stack-space
- ,(ceiling (alien-type-bits alien-type)
- sb!vm:n-byte-bits))
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:n-byte-bits))
nil)))
\f
;;;; %CAST
(defoptimizer (%cast derive-type) ((alien type))
(or (when (constant-lvar-p type)
- (let ((alien-type (lvar-value type)))
- (when (alien-type-p alien-type)
- (make-alien-type-type alien-type))))
+ (let ((alien-type (lvar-value type)))
+ (when (alien-type-p alien-type)
+ (make-alien-type-type alien-type))))
*wild-type*))
(deftransform %cast ((alien target-type) * * :important t)
"The alien type is not constant, so access cannot be open coded."))
(let ((target-type (lvar-value target-type)))
(cond ((or (alien-pointer-type-p target-type)
- (alien-array-type-p target-type)
- (alien-fun-type-p target-type))
- `(naturalize (alien-sap alien) ',target-type))
- (t
- (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))
+ (alien-array-type-p target-type)
+ (alien-fun-type-p target-type))
+ `(naturalize (alien-sap alien) ',target-type))
+ (t
+ (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))
\f
;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.
(combination
(extract-fun-args alien '%sap-alien 2)
'(lambda (sap type)
- (declare (ignore type))
- sap))
+ (declare (ignore type))
+ sap))
(t
(give-up-ir1-transform)))))
;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
(flet ((%computed-lambda (compute-lambda type)
- (declare (type function compute-lambda))
- (unless (constant-lvar-p type)
- (give-up-ir1-transform
- "The type is not constant at compile time; can't open code."))
- (handler-case
- (let ((result (funcall compute-lambda (lvar-value type))))
- (/noshow "in %COMPUTED-LAMBDA" (lvar-value type) result)
- result)
- (error (condition)
- (compiler-error "~A" condition)))))
+ (declare (type function compute-lambda))
+ (unless (constant-lvar-p type)
+ (give-up-ir1-transform
+ "The type is not constant at compile time; can't open code."))
+ (handler-case
+ (let ((result (funcall compute-lambda (lvar-value type))))
+ (/noshow "in %COMPUTED-LAMBDA" (lvar-value type) result)
+ result)
+ (error (condition)
+ (compiler-error "~A" condition)))))
(deftransform naturalize ((object type) * * :important t)
(%computed-lambda #'compute-naturalize-lambda type))
(deftransform deport ((alien type) * * :important t)
(typecase thing
(lvar
(if (constant-lvar-p thing)
- (count-low-order-zeros (lvar-value thing))
- (count-low-order-zeros (lvar-uses thing))))
+ (count-low-order-zeros (lvar-value thing))
+ (count-low-order-zeros (lvar-uses thing))))
(combination
(case (let ((name (lvar-fun-name (combination-fun thing))))
(or (modular-version-info name :unsigned) name))
((+ -)
- (let ((min most-positive-fixnum)
- (itype (specifier-type 'integer)))
- (dolist (arg (combination-args thing) min)
- (if (csubtypep (lvar-type arg) itype)
- (setf min (min min (count-low-order-zeros arg)))
- (return 0)))))
+ (let ((min most-positive-fixnum)
+ (itype (specifier-type 'integer)))
+ (dolist (arg (combination-args thing) min)
+ (if (csubtypep (lvar-type arg) itype)
+ (setf min (min min (count-low-order-zeros arg)))
+ (return 0)))))
(*
- (let ((result 0)
- (itype (specifier-type 'integer)))
- (dolist (arg (combination-args thing) result)
- (if (csubtypep (lvar-type arg) itype)
- (setf result (+ result (count-low-order-zeros arg)))
- (return 0)))))
+ (let ((result 0)
+ (itype (specifier-type 'integer)))
+ (dolist (arg (combination-args thing) result)
+ (if (csubtypep (lvar-type arg) itype)
+ (setf result (+ result (count-low-order-zeros arg)))
+ (return 0)))))
(ash
- (let ((args (combination-args thing)))
- (if (= (length args) 2)
- (let ((amount (second args)))
- (if (constant-lvar-p amount)
- (max (+ (count-low-order-zeros (first args))
- (lvar-value amount))
- 0)
- 0))
- 0)))
+ (let ((args (combination-args thing)))
+ (if (= (length args) 2)
+ (let ((amount (second args)))
+ (if (constant-lvar-p amount)
+ (max (+ (count-low-order-zeros (first args))
+ (lvar-value amount))
+ 0)
+ 0))
+ 0)))
(t
- 0)))
+ 0)))
(integer
(if (zerop thing)
- most-positive-fixnum
- (do ((result 0 (1+ result))
- (num thing (ash num -1)))
- ((logbitp 0 num) result))))
+ most-positive-fixnum
+ (do ((result 0 (1+ result))
+ (num thing (ash num -1)))
+ ((logbitp 0 num) result))))
(cast
(count-low-order-zeros (cast-value thing)))
(t
(unless (constant-lvar-p denominator)
(give-up-ir1-transform))
(let* ((denominator (lvar-value denominator))
- (bits (1- (integer-length denominator))))
+ (bits (1- (integer-length denominator))))
(unless (and (> denominator 0) (= (ash 1 bits) denominator))
(give-up-ir1-transform))
(let ((alignment (count-low-order-zeros numerator)))
(unless (>= alignment bits)
- (give-up-ir1-transform))
+ (give-up-ir1-transform))
`(ash numerator ,(- bits)))))
(deftransform ash ((value amount))
;;;; ALIEN-FUNCALL support
(deftransform alien-funcall ((function &rest args)
- ((alien (* t)) &rest *) *
- :important t)
+ ((alien (* t)) &rest *) *
+ :important t)
(let ((names (make-gensym-list (length args))))
(/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL" function args)
`(lambda (function ,@names)
(/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL" function)
(let ((alien-type (alien-type-type-alien-type type)))
(unless (alien-fun-type-p alien-type)
- (give-up-ir1-transform))
+ (give-up-ir1-transform))
(let ((arg-types (alien-fun-type-arg-types alien-type)))
- (unless (= (length args) (length arg-types))
- (abort-ir1-transform
- "wrong number of arguments; expected ~W, got ~W"
- (length arg-types)
- (length args)))
- (collect ((params) (deports))
- (dolist (arg-type arg-types)
- (let ((param (gensym)))
- (params param)
- (deports `(deport ,param ',arg-type))))
- (let ((return-type (alien-fun-type-result-type alien-type))
- (body `(%alien-funcall (deport function ',alien-type)
- ',alien-type
- ,@(deports))))
- (if (alien-values-type-p return-type)
- (collect ((temps) (results))
- (dolist (type (alien-values-type-values return-type))
- (let ((temp (gensym)))
- (temps temp)
- (results `(naturalize ,temp ',type))))
- (setf body
- `(multiple-value-bind ,(temps) ,body
- (values ,@(results)))))
- (setf body `(naturalize ,body ',return-type)))
- (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
- `(lambda (function ,@(params))
- ,body)))))))
+ (unless (= (length args) (length arg-types))
+ (abort-ir1-transform
+ "wrong number of arguments; expected ~W, got ~W"
+ (length arg-types)
+ (length args)))
+ (collect ((params) (deports))
+ (dolist (arg-type arg-types)
+ (let ((param (gensym)))
+ (params param)
+ (deports `(deport ,param ',arg-type))))
+ (let ((return-type (alien-fun-type-result-type alien-type))
+ (body `(%alien-funcall (deport function ',alien-type)
+ ',alien-type
+ ,@(deports))))
+ (if (alien-values-type-p return-type)
+ (collect ((temps) (results))
+ (dolist (type (alien-values-type-values return-type))
+ (let ((temp (gensym)))
+ (temps temp)
+ (results `(naturalize ,temp ',type))))
+ (setf body
+ `(multiple-value-bind ,(temps) ,body
+ (values ,@(results)))))
+ (setf body `(naturalize ,body ',return-type)))
+ (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
+ `(lambda (function ,@(params))
+ ,body)))))))
(defoptimizer (%alien-funcall derive-type) ((function type &rest args))
(declare (ignore function args))
(alien-fun-type-result-type type)))))
(defoptimizer (%alien-funcall ltn-annotate)
- ((function type &rest args) node ltn-policy)
+ ((function type &rest args) node ltn-policy)
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil)
(annotate-ordinary-lvar function)
(annotate-ordinary-lvar arg)))
(defoptimizer (%alien-funcall ir2-convert)
- ((function type &rest args) call block)
+ ((function type &rest args) call block)
(let ((type (if (constant-lvar-p type)
- (lvar-value type)
- (error "Something is broken.")))
- (lvar (node-lvar call))
- (args args))
+ (lvar-value type)
+ (error "Something is broken.")))
+ (lvar (node-lvar call))
+ (args args))
(multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
- (make-call-out-tns type)
+ (make-call-out-tns type)
(vop alloc-number-stack-space call block stack-frame-size nsp)
(dolist (tn arg-tns)
- (let* ((arg (pop args))
- (sc (tn-sc tn))
- (scn (sc-number sc))
- #!-(or x86 x86-64) (temp-tn (make-representation-tn (tn-primitive-type tn)
- scn))
- (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
- (aver arg)
- (unless (= (length move-arg-vops) 1)
- (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
- #!+(or x86 x86-64) (emit-move-arg-template call
- block
- (first move-arg-vops)
- (lvar-tn call block arg)
- nsp
- tn)
- #!-(or x86 x86-64) (progn
- (emit-move call
- block
- (lvar-tn call block arg)
- temp-tn)
- (emit-move-arg-template call
- block
- (first move-arg-vops)
- temp-tn
- nsp
- tn))))
+ (let* ((arg (pop args))
+ (sc (tn-sc tn))
+ (scn (sc-number sc))
+ #!-(or x86 x86-64) (temp-tn (make-representation-tn (tn-primitive-type tn)
+ scn))
+ (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
+ (aver arg)
+ (unless (= (length move-arg-vops) 1)
+ (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
+ #!+(or x86 x86-64) (emit-move-arg-template call
+ block
+ (first move-arg-vops)
+ (lvar-tn call block arg)
+ nsp
+ tn)
+ #!-(or x86 x86-64) (progn
+ (emit-move call
+ block
+ (lvar-tn call block arg)
+ temp-tn)
+ (emit-move-arg-template call
+ block
+ (first move-arg-vops)
+ temp-tn
+ nsp
+ tn))))
(aver (null args))
(unless (listp result-tns)
- (setf result-tns (list result-tns)))
+ (setf result-tns (list result-tns)))
(vop* call-out call block
- ((lvar-tn call block function)
- (reference-tn-list arg-tns nil))
- ((reference-tn-list result-tns t)))
+ ((lvar-tn call block function)
+ (reference-tn-list arg-tns nil))
+ ((reference-tn-list result-tns t)))
(vop dealloc-number-stack-space call block stack-frame-size)
(move-lvar-result call block result-tns lvar))))
;;; determined.
(defun upgraded-element-type-specifier-or-give-up (lvar)
(let* ((element-ctype (extract-upgraded-element-type lvar))
- (element-type-specifier (type-specifier element-ctype)))
+ (element-type-specifier (type-specifier element-ctype)))
(if (eq element-type-specifier '*)
- (give-up-ir1-transform
- "upgraded array element type not known at compile time")
- element-type-specifier)))
+ (give-up-ir1-transform
+ "upgraded array element type not known at compile time")
+ element-type-specifier)))
;;; Array access functions return an object from the array, hence its
;;; type is going to be the array upgraded element type.
;; which are represented in the compiler as INTERSECTION-TYPE, not
;; array type.
(if (array-type-p type)
- (array-type-specialized-element-type type)
- ;; KLUDGE: there is no good answer here, but at least
- ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
- ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
- ;; 2002-08-21
- *wild-type*)))
+ (array-type-specialized-element-type type)
+ ;; KLUDGE: there is no good answer here, but at least
+ ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
+ ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
+ ;; 2002-08-21
+ *wild-type*)))
(defun extract-declared-element-type (array)
(let ((type (lvar-type array)))
(if (array-type-p type)
- (array-type-element-type type)
- *wild-type*)))
+ (array-type-element-type type)
+ *wild-type*)))
;;; The ``new-value'' for array setters must fit in the array, and the
;;; return type is going to be the same as the new-value for SETF
(declare (type (or lvar null) arg))
(or (not arg)
(and (constant-lvar-p arg)
- (not (lvar-value arg)))))
+ (not (lvar-value arg)))))
\f
;;;; DERIVE-TYPE optimizers
(assert-new-value-type new-value array))
(defoptimizer (make-array derive-type)
- ((dims &key initial-element element-type initial-contents
- adjustable fill-pointer displaced-index-offset displaced-to))
+ ((dims &key initial-element element-type initial-contents
+ adjustable fill-pointer displaced-index-offset displaced-to))
(let ((simple (and (unsupplied-or-nil adjustable)
- (unsupplied-or-nil displaced-to)
- (unsupplied-or-nil fill-pointer))))
+ (unsupplied-or-nil displaced-to)
+ (unsupplied-or-nil fill-pointer))))
(or (careful-specifier-type
`(,(if simple 'simple-array 'array)
,(cond ((not element-type) t)
((constant-lvar-p element-type)
- (let ((ctype (careful-specifier-type
- (lvar-value element-type))))
- (cond
- ((or (null ctype) (unknown-type-p ctype)) '*)
- (t (sb!xc:upgraded-array-element-type
- (lvar-value element-type))))))
+ (let ((ctype (careful-specifier-type
+ (lvar-value element-type))))
+ (cond
+ ((or (null ctype) (unknown-type-p ctype)) '*)
+ (t (sb!xc:upgraded-array-element-type
+ (lvar-value element-type))))))
(t
'*))
,(cond ((constant-lvar-p dims)
(let* ((val (lvar-value dims))
- (cdims (if (listp val) val (list val))))
- (if simple
- cdims
- (length cdims))))
+ (cdims (if (listp val) val (list val))))
+ (if simple
+ cdims
+ (length cdims))))
((csubtypep (lvar-type dims)
(specifier-type 'integer))
'(*))
;;; elements.
(define-source-transform vector (&rest elements)
(let ((len (length elements))
- (n -1))
+ (n -1))
(once-only ((n-vec `(make-array ,len)))
`(progn
- ,@(mapcar (lambda (el)
- (once-only ((n-val el))
- `(locally (declare (optimize (safety 0)))
- (setf (svref ,n-vec ,(incf n))
- ,n-val))))
- elements)
- ,n-vec))))
+ ,@(mapcar (lambda (el)
+ (once-only ((n-val el))
+ `(locally (declare (optimize (safety 0)))
+ (setf (svref ,n-vec ,(incf n))
+ ,n-val))))
+ elements)
+ ,n-vec))))
;;; Just convert it into a MAKE-ARRAY.
(deftransform make-string ((length &key
- (element-type 'character)
- (initial-element
- #.*default-init-char-form*)))
+ (element-type 'character)
+ (initial-element
+ #.*default-init-char-form*)))
`(the simple-string (make-array (the index length)
- :element-type element-type
- ,@(when initial-element
- '(:initial-element initial-element)))))
+ :element-type element-type
+ ,@(when initial-element
+ '(:initial-element initial-element)))))
(deftransform make-array ((dims &key initial-element element-type
- adjustable fill-pointer)
- (t &rest *))
+ adjustable fill-pointer)
+ (t &rest *))
(when (null initial-element)
(give-up-ir1-transform))
(let* ((eltype (cond ((not element-type) t)
- ((not (constant-lvar-p element-type))
- (give-up-ir1-transform
- "ELEMENT-TYPE is not constant."))
- (t
- (lvar-value element-type))))
- (eltype-type (ir1-transform-specifier-type eltype))
- (saetp (find-if (lambda (saetp)
- (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
- sb!vm:*specialized-array-element-type-properties*))
- (creation-form `(make-array dims
- :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
- ,@(when fill-pointer
- '(:fill-pointer fill-pointer))
- ,@(when adjustable
- '(:adjustable adjustable)))))
+ ((not (constant-lvar-p element-type))
+ (give-up-ir1-transform
+ "ELEMENT-TYPE is not constant."))
+ (t
+ (lvar-value element-type))))
+ (eltype-type (ir1-transform-specifier-type eltype))
+ (saetp (find-if (lambda (saetp)
+ (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
+ sb!vm:*specialized-array-element-type-properties*))
+ (creation-form `(make-array dims
+ :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
+ ,@(when fill-pointer
+ '(:fill-pointer fill-pointer))
+ ,@(when adjustable
+ '(:adjustable adjustable)))))
(unless saetp
(give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
(cond ((and (constant-lvar-p initial-element)
- (eql (lvar-value initial-element)
- (sb!vm:saetp-initial-element-default saetp)))
- creation-form)
- (t
- ;; error checking for target, disabled on the host because
- ;; (CTYPE-OF #\Null) is not possible.
- #-sb-xc-host
- (when (constant-lvar-p initial-element)
- (let ((value (lvar-value initial-element)))
- (cond
- ((not (ctypep value (sb!vm:saetp-ctype saetp)))
- ;; this case will cause an error at runtime, so we'd
- ;; better WARN about it now.
- (warn 'array-initial-element-mismatch
- :format-control "~@<~S is not a ~S (which is the ~
+ (eql (lvar-value initial-element)
+ (sb!vm:saetp-initial-element-default saetp)))
+ creation-form)
+ (t
+ ;; error checking for target, disabled on the host because
+ ;; (CTYPE-OF #\Null) is not possible.
+ #-sb-xc-host
+ (when (constant-lvar-p initial-element)
+ (let ((value (lvar-value initial-element)))
+ (cond
+ ((not (ctypep value (sb!vm:saetp-ctype saetp)))
+ ;; this case will cause an error at runtime, so we'd
+ ;; better WARN about it now.
+ (warn 'array-initial-element-mismatch
+ :format-control "~@<~S is not a ~S (which is the ~
~S of ~S).~@:>"
- :format-arguments
- (list
- value
- (type-specifier (sb!vm:saetp-ctype saetp))
- 'upgraded-array-element-type
- eltype)))
- ((not (ctypep value eltype-type))
- ;; this case will not cause an error at runtime, but
- ;; it's still worth STYLE-WARNing about.
- (compiler-style-warn "~S is not a ~S."
- value eltype)))))
- `(let ((array ,creation-form))
- (multiple-value-bind (vector)
- (%data-vector-and-index array 0)
- (fill vector initial-element))
- array)))))
+ :format-arguments
+ (list
+ value
+ (type-specifier (sb!vm:saetp-ctype saetp))
+ 'upgraded-array-element-type
+ eltype)))
+ ((not (ctypep value eltype-type))
+ ;; this case will not cause an error at runtime, but
+ ;; it's still worth STYLE-WARNing about.
+ (compiler-style-warn "~S is not a ~S."
+ value eltype)))))
+ `(let ((array ,creation-form))
+ (multiple-value-bind (vector)
+ (%data-vector-and-index array 0)
+ (fill vector initial-element))
+ array)))))
;;; The integer type restriction on the length ensures that it will be
;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and
;;; :INITIAL-ELEMENT relies on another transform to deal with that
;;; kind of initialization efficiently.
(deftransform make-array ((length &key element-type)
- (integer &rest *))
+ (integer &rest *))
(let* ((eltype (cond ((not element-type) t)
- ((not (constant-lvar-p element-type))
- (give-up-ir1-transform
- "ELEMENT-TYPE is not constant."))
- (t
- (lvar-value element-type))))
- (len (if (constant-lvar-p length)
- (lvar-value length)
- '*))
- (eltype-type (ir1-transform-specifier-type eltype))
- (result-type-spec
- `(simple-array
- ,(if (unknown-type-p eltype-type)
- (give-up-ir1-transform
- "ELEMENT-TYPE is an unknown type: ~S" eltype)
- (sb!xc:upgraded-array-element-type eltype))
- (,len)))
- (saetp (find-if (lambda (saetp)
- (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
- sb!vm:*specialized-array-element-type-properties*)))
+ ((not (constant-lvar-p element-type))
+ (give-up-ir1-transform
+ "ELEMENT-TYPE is not constant."))
+ (t
+ (lvar-value element-type))))
+ (len (if (constant-lvar-p length)
+ (lvar-value length)
+ '*))
+ (eltype-type (ir1-transform-specifier-type eltype))
+ (result-type-spec
+ `(simple-array
+ ,(if (unknown-type-p eltype-type)
+ (give-up-ir1-transform
+ "ELEMENT-TYPE is an unknown type: ~S" eltype)
+ (sb!xc:upgraded-array-element-type eltype))
+ (,len)))
+ (saetp (find-if (lambda (saetp)
+ (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
+ sb!vm:*specialized-array-element-type-properties*)))
(unless saetp
(give-up-ir1-transform
"cannot open-code creation of ~S" result-type-spec))
;; he writes code:-), we'll signal a STYLE-WARNING in case he
;; didn't realize this.
(compiler-style-warn "The default initial element ~S is not a ~S."
- (sb!vm:saetp-initial-element-default saetp)
- eltype))
+ (sb!vm:saetp-initial-element-default saetp)
+ eltype))
(let* ((n-bits-per-element (sb!vm:saetp-n-bits saetp))
- (typecode (sb!vm:saetp-typecode saetp))
- (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
- (padded-length-form (if (zerop n-pad-elements)
- 'length
- `(+ length ,n-pad-elements)))
- (n-words-form
- (cond
- ((= n-bits-per-element 0) 0)
- ((>= n-bits-per-element sb!vm:n-word-bits)
- `(* ,padded-length-form
- (the fixnum ; i.e., not RATIO
- ,(/ n-bits-per-element sb!vm:n-word-bits))))
- (t
- (let ((n-elements-per-word (/ sb!vm:n-word-bits
- n-bits-per-element)))
- (declare (type index n-elements-per-word)) ; i.e., not RATIO
- `(ceiling ,padded-length-form ,n-elements-per-word))))))
+ (typecode (sb!vm:saetp-typecode saetp))
+ (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
+ (padded-length-form (if (zerop n-pad-elements)
+ 'length
+ `(+ length ,n-pad-elements)))
+ (n-words-form
+ (cond
+ ((= n-bits-per-element 0) 0)
+ ((>= n-bits-per-element sb!vm:n-word-bits)
+ `(* ,padded-length-form
+ (the fixnum ; i.e., not RATIO
+ ,(/ n-bits-per-element sb!vm:n-word-bits))))
+ (t
+ (let ((n-elements-per-word (/ sb!vm:n-word-bits
+ n-bits-per-element)))
+ (declare (type index n-elements-per-word)) ; i.e., not RATIO
+ `(ceiling ,padded-length-form ,n-elements-per-word))))))
(values
`(truly-the ,result-type-spec
- (allocate-vector ,typecode length ,n-words-form))
+ (allocate-vector ,typecode length ,n-words-form))
'((declare (type index length)))))))
;;; The list type restriction does not ensure that the result will be a
;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
;;; CSR, 2002-07-01
(deftransform make-array ((dims &key element-type)
- (list &rest *))
+ (list &rest *))
(unless (or (null element-type) (constant-lvar-p element-type))
(give-up-ir1-transform
"The element-type is not constant; cannot open code array creation."))
"The dimension list contains something other than an integer: ~S"
dims))
(if (= (length dims) 1)
- `(make-array ',(car dims)
- ,@(when element-type
- '(:element-type element-type)))
- (let* ((total-size (reduce #'* dims))
- (rank (length dims))
- (spec `(simple-array
- ,(cond ((null element-type) t)
- ((and (constant-lvar-p element-type)
- (ir1-transform-specifier-type
- (lvar-value element-type)))
- (sb!xc:upgraded-array-element-type
- (lvar-value element-type)))
- (t '*))
- ,(make-list rank :initial-element '*))))
- `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
- (setf (%array-fill-pointer header) ,total-size)
- (setf (%array-fill-pointer-p header) nil)
- (setf (%array-available-elements header) ,total-size)
- (setf (%array-data-vector header)
- (make-array ,total-size
- ,@(when element-type
- '(:element-type element-type))))
- (setf (%array-displaced-p header) nil)
- ,@(let ((axis -1))
- (mapcar (lambda (dim)
- `(setf (%array-dimension header ,(incf axis))
- ,dim))
- dims))
- (truly-the ,spec header))))))
+ `(make-array ',(car dims)
+ ,@(when element-type
+ '(:element-type element-type)))
+ (let* ((total-size (reduce #'* dims))
+ (rank (length dims))
+ (spec `(simple-array
+ ,(cond ((null element-type) t)
+ ((and (constant-lvar-p element-type)
+ (ir1-transform-specifier-type
+ (lvar-value element-type)))
+ (sb!xc:upgraded-array-element-type
+ (lvar-value element-type)))
+ (t '*))
+ ,(make-list rank :initial-element '*))))
+ `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
+ (setf (%array-fill-pointer header) ,total-size)
+ (setf (%array-fill-pointer-p header) nil)
+ (setf (%array-available-elements header) ,total-size)
+ (setf (%array-data-vector header)
+ (make-array ,total-size
+ ,@(when element-type
+ '(:element-type element-type))))
+ (setf (%array-displaced-p header) nil)
+ ,@(let ((axis -1))
+ (mapcar (lambda (dim)
+ `(setf (%array-dimension header ,(incf axis))
+ ,dim))
+ dims))
+ (truly-the ,spec header))))))
\f
;;;; miscellaneous properties of arrays
;; there are at least two types, right?
(aver (> (length types) 1))
(let ((result (array-type-dimensions-or-give-up (car types))))
- (dolist (type (cdr types) result)
- (unless (equal (array-type-dimensions-or-give-up type) result)
- (give-up-ir1-transform))))))
+ (dolist (type (cdr types) result)
+ (unless (equal (array-type-dimensions-or-give-up type) result)
+ (give-up-ir1-transform))))))
;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ]
(t (give-up-ir1-transform))))
(let ((types (union-type-types type)))
(aver (> (length types) 1))
(let ((result (conservative-array-type-complexp (car types))))
- (dolist (type (cdr types) result)
- (unless (eq (conservative-array-type-complexp type) result)
- (return-from conservative-array-type-complexp :maybe))))))
+ (dolist (type (cdr types) result)
+ (unless (eq (conservative-array-type-complexp type) result)
+ (return-from conservative-array-type-complexp :maybe))))))
;; FIXME: intersection type
(t :maybe)))
(let ((array-type (lvar-type array)))
(let ((dims (array-type-dimensions-or-give-up array-type)))
(if (not (listp dims))
- (give-up-ir1-transform
- "The array rank is not known at compile time: ~S"
- dims)
- (length dims)))))
+ (give-up-ir1-transform
+ "The array rank is not known at compile time: ~S"
+ dims)
+ (length dims)))))
;;; If we know the dimensions at compile time, just use it. Otherwise,
;;; if we can tell that the axis is in bounds, convert to
;;; %ARRAY-DIMENSION (which just indirects the array header) or length
;;; (if it's simple and a vector).
(deftransform array-dimension ((array axis)
- (array index))
+ (array index))
(unless (constant-lvar-p axis)
(give-up-ir1-transform "The axis is not constant."))
(let ((array-type (lvar-type array))
- (axis (lvar-value axis)))
+ (axis (lvar-value axis)))
(let ((dims (array-type-dimensions-or-give-up array-type)))
(unless (listp dims)
- (give-up-ir1-transform
- "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
+ (give-up-ir1-transform
+ "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
(unless (> (length dims) axis)
- (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
- dims
- axis))
+ (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
+ dims
+ axis))
(let ((dim (nth axis dims)))
- (cond ((integerp dim)
- dim)
- ((= (length dims) 1)
- (ecase (conservative-array-type-complexp array-type)
- ((t)
- '(%array-dimension array 0))
- ((nil)
- '(length array))
- ((:maybe)
- (give-up-ir1-transform
- "can't tell whether array is simple"))))
- (t
- '(%array-dimension array axis)))))))
+ (cond ((integerp dim)
+ dim)
+ ((= (length dims) 1)
+ (ecase (conservative-array-type-complexp array-type)
+ ((t)
+ '(%array-dimension array 0))
+ ((nil)
+ '(length array))
+ ((:maybe)
+ (give-up-ir1-transform
+ "can't tell whether array is simple"))))
+ (t
+ '(%array-dimension array axis)))))))
;;; If the length has been declared and it's simple, just return it.
(deftransform length ((vector)
- ((simple-array * (*))))
+ ((simple-array * (*))))
(let ((type (lvar-type vector)))
(let ((dims (array-type-dimensions-or-give-up type)))
(unless (and (listp dims) (integerp (car dims)))
- (give-up-ir1-transform
- "Vector length is unknown, must call LENGTH at runtime."))
+ (give-up-ir1-transform
+ "Vector length is unknown, must call LENGTH at runtime."))
(car dims))))
;;; All vectors can get their length by using VECTOR-LENGTH. If it's
(let ((vtype (lvar-type vector)))
(let ((dim (first (array-type-dimensions-or-give-up vtype))))
(when (eq dim '*)
- (give-up-ir1-transform))
+ (give-up-ir1-transform))
(when (conservative-array-type-complexp vtype)
- (give-up-ir1-transform))
+ (give-up-ir1-transform))
dim)))
;;; Again, if we can tell the results from the type, just use it.
;;; multiplications because we know that the total size must be an
;;; INDEX.
(deftransform array-total-size ((array)
- (array))
+ (array))
(let ((array-type (lvar-type array)))
(let ((dims (array-type-dimensions-or-give-up array-type)))
(unless (listp dims)
- (give-up-ir1-transform "can't tell the rank at compile time"))
+ (give-up-ir1-transform "can't tell the rank at compile time"))
(if (member '* dims)
- (do ((form 1 `(truly-the index
- (* (array-dimension array ,i) ,form)))
- (i 0 (1+ i)))
- ((= i (length dims)) form))
- (reduce #'* dims)))))
+ (do ((form 1 `(truly-the index
+ (* (array-dimension array ,i) ,form)))
+ (i 0 (1+ i)))
+ ((= i (length dims)) form))
+ (reduce #'* dims)))))
;;; Only complex vectors have fill pointers.
(deftransform array-has-fill-pointer-p ((array))
(let ((array-type (lvar-type array)))
(let ((dims (array-type-dimensions-or-give-up array-type)))
(if (and (listp dims) (not (= (length dims) 1)))
- nil
- (ecase (conservative-array-type-complexp array-type)
- ((t)
- t)
- ((nil)
- nil)
- ((:maybe)
- (give-up-ir1-transform
- "The array type is ambiguous; must call ~
+ nil
+ (ecase (conservative-array-type-complexp array-type)
+ ((t)
+ t)
+ ((nil)
+ nil)
+ ((:maybe)
+ (give-up-ir1-transform
+ "The array type is ambiguous; must call ~
ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
;;; Primitive used to verify indices into arrays. If we can tell at
;;; the DEFTRANSFORM can't tell that that's going on, so it can make
;;; sense to use FORCE-INLINE option in that case.
(def!macro with-array-data (((data-var array &key offset-var)
- (start-var &optional (svalue 0))
- (end-var &optional (evalue nil))
- &key force-inline)
- &body forms)
+ (start-var &optional (svalue 0))
+ (end-var &optional (evalue nil))
+ &key force-inline)
+ &body forms)
(once-only ((n-array array)
- (n-svalue `(the index ,svalue))
- (n-evalue `(the (or index null) ,evalue)))
+ (n-svalue `(the index ,svalue))
+ (n-evalue `(the (or index null) ,evalue)))
`(multiple-value-bind (,data-var
- ,start-var
- ,end-var
- ,@(when offset-var `(,offset-var)))
- (if (not (array-header-p ,n-array))
- (let ((,n-array ,n-array))
- (declare (type (simple-array * (*)) ,n-array))
- ,(once-only ((n-len `(length ,n-array))
- (n-end `(or ,n-evalue ,n-len)))
- `(if (<= ,n-svalue ,n-end ,n-len)
- ;; success
- (values ,n-array ,n-svalue ,n-end 0)
- (failed-%with-array-data ,n-array
- ,n-svalue
- ,n-evalue))))
- (,(if force-inline '%with-array-data-macro '%with-array-data)
- ,n-array ,n-svalue ,n-evalue))
+ ,start-var
+ ,end-var
+ ,@(when offset-var `(,offset-var)))
+ (if (not (array-header-p ,n-array))
+ (let ((,n-array ,n-array))
+ (declare (type (simple-array * (*)) ,n-array))
+ ,(once-only ((n-len `(length ,n-array))
+ (n-end `(or ,n-evalue ,n-len)))
+ `(if (<= ,n-svalue ,n-end ,n-len)
+ ;; success
+ (values ,n-array ,n-svalue ,n-end 0)
+ (failed-%with-array-data ,n-array
+ ,n-svalue
+ ,n-evalue))))
+ (,(if force-inline '%with-array-data-macro '%with-array-data)
+ ,n-array ,n-svalue ,n-evalue))
,@forms)))
;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
;;; DEFTRANSFORMs and DEFUNs.
(def!macro %with-array-data-macro (array
- start
- end
- &key
- (element-type '*)
- unsafe?
- fail-inline?)
+ start
+ end
+ &key
+ (element-type '*)
+ unsafe?
+ fail-inline?)
(with-unique-names (size defaulted-end data cumulative-offset)
`(let* ((,size (array-total-size ,array))
- (,defaulted-end
- (cond (,end
- (unless (or ,unsafe? (<= ,end ,size))
- ,(if fail-inline?
- `(error 'bounding-indices-bad-error
- :datum (cons ,start ,end)
- :expected-type `(cons (integer 0 ,',size)
- (integer ,',start ,',size))
- :object ,array)
- `(failed-%with-array-data ,array ,start ,end)))
- ,end)
- (t ,size))))
+ (,defaulted-end
+ (cond (,end
+ (unless (or ,unsafe? (<= ,end ,size))
+ ,(if fail-inline?
+ `(error 'bounding-indices-bad-error
+ :datum (cons ,start ,end)
+ :expected-type `(cons (integer 0 ,',size)
+ (integer ,',start ,',size))
+ :object ,array)
+ `(failed-%with-array-data ,array ,start ,end)))
+ ,end)
+ (t ,size))))
(unless (or ,unsafe? (<= ,start ,defaulted-end))
- ,(if fail-inline?
- `(error 'bounding-indices-bad-error
- :datum (cons ,start ,end)
- :expected-type `(cons (integer 0 ,',size)
- (integer ,',start ,',size))
- :object ,array)
- `(failed-%with-array-data ,array ,start ,end)))
+ ,(if fail-inline?
+ `(error 'bounding-indices-bad-error
+ :datum (cons ,start ,end)
+ :expected-type `(cons (integer 0 ,',size)
+ (integer ,',start ,',size))
+ :object ,array)
+ `(failed-%with-array-data ,array ,start ,end)))
(do ((,data ,array (%array-data-vector ,data))
- (,cumulative-offset 0
- (+ ,cumulative-offset
- (%array-displacement ,data))))
- ((not (array-header-p ,data))
- (values (the (simple-array ,element-type 1) ,data)
- (the index (+ ,cumulative-offset ,start))
- (the index (+ ,cumulative-offset ,defaulted-end))
- (the index ,cumulative-offset)))
- (declare (type index ,cumulative-offset))))))
+ (,cumulative-offset 0
+ (+ ,cumulative-offset
+ (%array-displacement ,data))))
+ ((not (array-header-p ,data))
+ (values (the (simple-array ,element-type 1) ,data)
+ (the index (+ ,cumulative-offset ,start))
+ (the index (+ ,cumulative-offset ,defaulted-end))
+ (the index ,cumulative-offset)))
+ (declare (type index ,cumulative-offset))))))
(deftransform %with-array-data ((array start end)
- ;; It might very well be reasonable to
- ;; allow general ARRAY here, I just
- ;; haven't tried to understand the
- ;; performance issues involved. --
- ;; WHN, and also CSR 2002-05-26
- ((or vector simple-array) index (or index null))
- *
- :node node
- :policy (> speed space))
+ ;; It might very well be reasonable to
+ ;; allow general ARRAY here, I just
+ ;; haven't tried to understand the
+ ;; performance issues involved. --
+ ;; WHN, and also CSR 2002-05-26
+ ((or vector simple-array) index (or index null))
+ *
+ :node node
+ :policy (> speed space))
"inline non-SIMPLE-vector-handling logic"
(let ((element-type (upgraded-element-type-specifier-or-give-up array)))
`(%with-array-data-macro array start end
- :unsafe? ,(policy node (= safety 0))
- :element-type ,element-type)))
+ :unsafe? ,(policy node (= safety 0))
+ :element-type ,element-type)))
\f
;;;; array accessors
;;; We convert all typed array accessors into AREF and %ASET with type
;;; assertions on the array.
(macrolet ((define-bit-frob (reffer setter simplep)
- `(progn
- (define-source-transform ,reffer (a &rest i)
- `(aref (the (,',(if simplep 'simple-array 'array)
- bit
- ,(mapcar (constantly '*) i))
- ,a) ,@i))
- (define-source-transform ,setter (a &rest i)
- `(%aset (the (,',(if simplep 'simple-array 'array)
- bit
- ,(cdr (mapcar (constantly '*) i)))
- ,a) ,@i)))))
+ `(progn
+ (define-source-transform ,reffer (a &rest i)
+ `(aref (the (,',(if simplep 'simple-array 'array)
+ bit
+ ,(mapcar (constantly '*) i))
+ ,a) ,@i))
+ (define-source-transform ,setter (a &rest i)
+ `(%aset (the (,',(if simplep 'simple-array 'array)
+ bit
+ ,(cdr (mapcar (constantly '*) i)))
+ ,a) ,@i)))))
(define-bit-frob sbit %sbitset t)
(define-bit-frob bit %bitset nil))
(macrolet ((define-frob (reffer setter type)
- `(progn
- (define-source-transform ,reffer (a i)
- `(aref (the ,',type ,a) ,i))
- (define-source-transform ,setter (a i v)
- `(%aset (the ,',type ,a) ,i ,v)))))
+ `(progn
+ (define-source-transform ,reffer (a i)
+ `(aref (the ,',type ,a) ,i))
+ (define-source-transform ,setter (a i v)
+ `(%aset (the ,',type ,a) ,i ,v)))))
(define-frob svref %svset simple-vector)
(define-frob schar %scharset simple-string)
(define-frob char %charset string))
(macrolet (;; This is a handy macro for computing the row-major index
- ;; given a set of indices. We wrap each index with a call
- ;; to %CHECK-BOUND to ensure that everything works out
- ;; correctly. We can wrap all the interior arithmetic with
- ;; TRULY-THE INDEX because we know the resultant
- ;; row-major index must be an index.
- (with-row-major-index ((array indices index &optional new-value)
- &rest body)
- `(let (n-indices dims)
- (dotimes (i (length ,indices))
- (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
- (push (make-symbol (format nil "DIM-~D" i)) dims))
- (setf n-indices (nreverse n-indices))
- (setf dims (nreverse dims))
- `(lambda (,',array ,@n-indices
- ,@',(when new-value (list new-value)))
- (let* (,@(let ((,index -1))
- (mapcar (lambda (name)
- `(,name (array-dimension
- ,',array
- ,(incf ,index))))
- dims))
- (,',index
- ,(if (null dims)
- 0
- (do* ((dims dims (cdr dims))
- (indices n-indices (cdr indices))
- (last-dim nil (car dims))
- (form `(%check-bound ,',array
- ,(car dims)
- ,(car indices))
- `(truly-the
- index
- (+ (truly-the index
- (* ,form
- ,last-dim))
- (%check-bound
- ,',array
- ,(car dims)
- ,(car indices))))))
- ((null (cdr dims)) form)))))
- ,',@body)))))
+ ;; given a set of indices. We wrap each index with a call
+ ;; to %CHECK-BOUND to ensure that everything works out
+ ;; correctly. We can wrap all the interior arithmetic with
+ ;; TRULY-THE INDEX because we know the resultant
+ ;; row-major index must be an index.
+ (with-row-major-index ((array indices index &optional new-value)
+ &rest body)
+ `(let (n-indices dims)
+ (dotimes (i (length ,indices))
+ (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
+ (push (make-symbol (format nil "DIM-~D" i)) dims))
+ (setf n-indices (nreverse n-indices))
+ (setf dims (nreverse dims))
+ `(lambda (,',array ,@n-indices
+ ,@',(when new-value (list new-value)))
+ (let* (,@(let ((,index -1))
+ (mapcar (lambda (name)
+ `(,name (array-dimension
+ ,',array
+ ,(incf ,index))))
+ dims))
+ (,',index
+ ,(if (null dims)
+ 0
+ (do* ((dims dims (cdr dims))
+ (indices n-indices (cdr indices))
+ (last-dim nil (car dims))
+ (form `(%check-bound ,',array
+ ,(car dims)
+ ,(car indices))
+ `(truly-the
+ index
+ (+ (truly-the index
+ (* ,form
+ ,last-dim))
+ (%check-bound
+ ,',array
+ ,(car dims)
+ ,(car indices))))))
+ ((null (cdr dims)) form)))))
+ ,',@body)))))
;; Just return the index after computing it.
(deftransform array-row-major-index ((array &rest indices))
(deftransform %aset ((array &rest stuff))
(let ((indices (butlast stuff)))
(with-row-major-index (array indices index new-value)
- (hairy-data-vector-set array index new-value)))))
+ (hairy-data-vector-set array index new-value)))))
;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
;;; array total size.
(deftransform row-major-aref ((array index))
`(hairy-data-vector-ref array
- (%check-bound array (array-total-size array) index)))
+ (%check-bound array (array-total-size array) index)))
(deftransform %set-row-major-aref ((array index new-value))
`(hairy-data-vector-set array
- (%check-bound array (array-total-size array) index)
- new-value))
+ (%check-bound array (array-total-size array) index)
+ new-value))
\f
;;;; bit-vector array operation canonicalization
;;;;
(macrolet ((def (fun)
`(progn
(deftransform ,fun ((bit-array-1 bit-array-2
- &optional result-bit-array)
+ &optional result-bit-array)
(bit-vector bit-vector &optional null) *
:policy (>= speed space))
`(,',fun bit-array-1 bit-array-2
;;; Similar for BIT-NOT, but there is only one arg...
(deftransform bit-not ((bit-array-1 &optional result-bit-array)
- (bit-vector &optional null) *
- :policy (>= speed space))
+ (bit-vector &optional null) *
+ :policy (>= speed space))
'(bit-not bit-array-1
- (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
+ (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
(deftransform bit-not ((bit-array-1 result-bit-array)
- (bit-vector (eql t)))
+ (bit-vector (eql t)))
'(bit-not bit-array-1 bit-array-1))
\f
;;; Pick off some constant cases.
(defoptimizer (array-header-p derive-type) ((array))
(let ((type (lvar-type array)))
(cond ((not (array-type-p type))
- ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
+ ;; FIXME: use analogue of ARRAY-TYPE-DIMENSIONS-OR-GIVE-UP
nil)
(t
(let ((dims (array-type-dimensions type)))
;; the segment is made invalid (e.g. by APPEND-SEGMENT) then the
;; vector can be replaced by NIL.
(buffer (make-array 0
- :fill-pointer 0
- :adjustable t
- :element-type 'assembly-unit)
- :type (or null (vector assembly-unit)))
+ :fill-pointer 0
+ :adjustable t
+ :element-type 'assembly-unit)
+ :type (or null (vector assembly-unit)))
;; whether or not to run the scheduler. Note: if the instruction
;; definitions were not compiled with the scheduler turned on, this
;; has no effect.
;; SIMPLE-VECTORs mapping locations to the instruction that reads them and
;; instructions that write them
(readers (make-array *assem-max-locations* :initial-element nil)
- :type simple-vector)
+ :type simple-vector)
(writers (make-array *assem-max-locations* :initial-element nil)
- :type simple-vector)
+ :type simple-vector)
;; The number of additional cycles before the next control transfer,
;; or NIL if a control transfer hasn't been queued. When a delayed
;; branch is queued, this slot is set to the delay count.
(let ((buffer (segment-buffer segment)))
;; Make sure that the array is big enough.
(do ()
- ((>= (array-dimension buffer 0) new-value))
+ ((>= (array-dimension buffer 0) new-value))
;; When we have to increase the size of the array, we want to
;; roughly double the vector length: that way growing the array
;; to size N conses only O(N) bytes in total. But just doubling
;;; FIXME: It'd probably be better to cleanly parameterize things like
;;; BACK-PATCH-FUN so we can avoid this nastiness altogether.
(defmacro with-modified-segment-index-and-posn ((segment index posn)
- &body body)
+ &body body)
(with-unique-names (n-segment old-index old-posn)
`(let* ((,n-segment ,segment)
- (,old-index (segment-current-index ,n-segment))
- (,old-posn (segment-current-posn ,n-segment)))
+ (,old-index (segment-current-index ,n-segment))
+ (,old-posn (segment-current-posn ,n-segment)))
(unwind-protect
- (progn
- (setf (segment-current-index ,n-segment) ,index
- (segment-current-posn ,n-segment) ,posn)
- ,@body)
- (setf (segment-current-index ,n-segment) ,old-index
- (segment-current-posn ,n-segment) ,old-posn)))))
+ (progn
+ (setf (segment-current-index ,n-segment) ,index
+ (segment-current-posn ,n-segment) ,posn)
+ ,@body)
+ (setf (segment-current-index ,n-segment) ,old-index
+ (segment-current-posn ,n-segment) ,old-posn)))))
\f
;;;; structures/types used by the scheduler
variable-length)
(def!struct (instruction
- (:include sset-element)
- (:conc-name inst-)
- (:constructor make-instruction (number emitter attributes delay))
- (:copier nil))
+ (:include sset-element)
+ (:conc-name inst-)
+ (:constructor make-instruction (number emitter attributes delay))
+ (:copier nil))
;; The function to envoke to actually emit this instruction. Gets called
;; with the segment as its one argument.
(emitter (missing-arg) :type (or null function))
(print-unreadable-object (inst stream :type t :identity t)
#!+sb-show-assem
(princ (or (gethash inst *inst-ids*)
- (setf (gethash inst *inst-ids*)
- (incf *next-inst-id*)))
- stream)
+ (setf (gethash inst *inst-ids*)
+ (incf *next-inst-id*)))
+ stream)
(format stream
- #!+sb-show-assem " emitter=~S" #!-sb-show-assem "emitter=~S"
- (let ((emitter (inst-emitter inst)))
- (if emitter
- (multiple-value-bind (lambda lexenv-p name)
- (function-lambda-expression emitter)
- (declare (ignore lambda lexenv-p))
- name)
- '<flushed>)))
+ #!+sb-show-assem " emitter=~S" #!-sb-show-assem "emitter=~S"
+ (let ((emitter (inst-emitter inst)))
+ (if emitter
+ (multiple-value-bind (lambda lexenv-p name)
+ (function-lambda-expression emitter)
+ (declare (ignore lambda lexenv-p))
+ name)
+ '<flushed>)))
(when (inst-depth inst)
(format stream ", depth=~W" (inst-depth inst)))))
;;;; the scheduler itself
(defmacro without-scheduling ((&optional (segment '(%%current-segment%%)))
- &body body)
+ &body body)
#!+sb-doc
"Execute BODY (as a PROGN) without scheduling any of the instructions
generated inside it. This is not protected by UNWIND-PROTECT, so
;; FIXME: Why not just use UNWIND-PROTECT? Or is there some other
;; reason why we shouldn't use THROW or RETURN-FROM?
(let ((var (gensym))
- (seg (gensym)))
+ (seg (gensym)))
`(let* ((,seg ,segment)
- (,var (segment-run-scheduler ,seg)))
+ (,var (segment-run-scheduler ,seg)))
(when ,var
- (schedule-pending-instructions ,seg)
- (setf (segment-run-scheduler ,seg) nil))
+ (schedule-pending-instructions ,seg)
+ (setf (segment-run-scheduler ,seg) nil))
,@body
(setf (segment-run-scheduler ,seg) ,var))))
(defmacro note-dependencies ((segment inst) &body body)
(sb!int:once-only ((segment segment) (inst inst))
`(macrolet ((reads (loc) `(note-read-dependency ,',segment ,',inst ,loc))
- (writes (loc &rest keys)
- `(note-write-dependency ,',segment ,',inst ,loc ,@keys)))
+ (writes (loc &rest keys)
+ `(note-write-dependency ,',segment ,',inst ,loc ,@keys)))
,@body)))
(defun note-read-dependency (segment inst read)
(multiple-value-bind (loc-num size)
(sb!c:location-number read)
#!+sb-show-assem (format *trace-output*
- "~&~S reads ~S[~W for ~W]~%"
- inst read loc-num size)
+ "~&~S reads ~S[~W for ~W]~%"
+ inst read loc-num size)
(when loc-num
;; Iterate over all the locations for this TN.
(do ((index loc-num (1+ index))
- (end-loc (+ loc-num (or size 1))))
- ((>= index end-loc))
- (declare (type (mod 2048) index end-loc))
- (let ((writers (svref (segment-writers segment) index)))
- (when writers
- ;; The inst that wrote the value we want to read must have
- ;; completed.
- (let ((writer (car writers)))
- (sset-adjoin writer (inst-read-dependencies inst))
- (sset-adjoin inst (inst-read-dependents writer))
- (sset-delete writer (segment-emittable-insts-sset segment))
- ;; And it must have been completed *after* all other
- ;; writes to that location. Actually, that isn't quite
- ;; true. Each of the earlier writes could be done
- ;; either before this last write, or after the read, but
- ;; we have no way of representing that.
- (dolist (other-writer (cdr writers))
- (sset-adjoin other-writer (inst-write-dependencies writer))
- (sset-adjoin writer (inst-write-dependents other-writer))
- (sset-delete other-writer
- (segment-emittable-insts-sset segment))))
- ;; And we don't need to remember about earlier writes any
- ;; more. Shortening the writers list means that we won't
- ;; bother generating as many explicit arcs in the graph.
- (setf (cdr writers) nil)))
- (push inst (svref (segment-readers segment) index)))))
+ (end-loc (+ loc-num (or size 1))))
+ ((>= index end-loc))
+ (declare (type (mod 2048) index end-loc))
+ (let ((writers (svref (segment-writers segment) index)))
+ (when writers
+ ;; The inst that wrote the value we want to read must have
+ ;; completed.
+ (let ((writer (car writers)))
+ (sset-adjoin writer (inst-read-dependencies inst))
+ (sset-adjoin inst (inst-read-dependents writer))
+ (sset-delete writer (segment-emittable-insts-sset segment))
+ ;; And it must have been completed *after* all other
+ ;; writes to that location. Actually, that isn't quite
+ ;; true. Each of the earlier writes could be done
+ ;; either before this last write, or after the read, but
+ ;; we have no way of representing that.
+ (dolist (other-writer (cdr writers))
+ (sset-adjoin other-writer (inst-write-dependencies writer))
+ (sset-adjoin writer (inst-write-dependents other-writer))
+ (sset-delete other-writer
+ (segment-emittable-insts-sset segment))))
+ ;; And we don't need to remember about earlier writes any
+ ;; more. Shortening the writers list means that we won't
+ ;; bother generating as many explicit arcs in the graph.
+ (setf (cdr writers) nil)))
+ (push inst (svref (segment-readers segment) index)))))
(values))
(defun note-write-dependency (segment inst write &key partially)
(multiple-value-bind (loc-num size)
(sb!c:location-number write)
#!+sb-show-assem (format *trace-output*
- "~&~S writes ~S[~W for ~W]~%"
- inst write loc-num size)
+ "~&~S writes ~S[~W for ~W]~%"
+ inst write loc-num size)
(when loc-num
;; Iterate over all the locations for this TN.
(do ((index loc-num (1+ index))
- (end-loc (+ loc-num (or size 1))))
- ((>= index end-loc))
- (declare (type (mod 2048) index end-loc))
- ;; All previous reads of this location must have completed.
- (dolist (prev-inst (svref (segment-readers segment) index))
- (unless (eq prev-inst inst)
- (sset-adjoin prev-inst (inst-write-dependencies inst))
- (sset-adjoin inst (inst-write-dependents prev-inst))
- (sset-delete prev-inst (segment-emittable-insts-sset segment))))
- (when partially
- ;; All previous writes to the location must have completed.
- (dolist (prev-inst (svref (segment-writers segment) index))
- (sset-adjoin prev-inst (inst-write-dependencies inst))
- (sset-adjoin inst (inst-write-dependents prev-inst))
- (sset-delete prev-inst (segment-emittable-insts-sset segment)))
- ;; And we can forget about remembering them, because
- ;; depending on us is as good as depending on them.
- (setf (svref (segment-writers segment) index) nil))
- (push inst (svref (segment-writers segment) index)))))
+ (end-loc (+ loc-num (or size 1))))
+ ((>= index end-loc))
+ (declare (type (mod 2048) index end-loc))
+ ;; All previous reads of this location must have completed.
+ (dolist (prev-inst (svref (segment-readers segment) index))
+ (unless (eq prev-inst inst)
+ (sset-adjoin prev-inst (inst-write-dependencies inst))
+ (sset-adjoin inst (inst-write-dependents prev-inst))
+ (sset-delete prev-inst (segment-emittable-insts-sset segment))))
+ (when partially
+ ;; All previous writes to the location must have completed.
+ (dolist (prev-inst (svref (segment-writers segment) index))
+ (sset-adjoin prev-inst (inst-write-dependencies inst))
+ (sset-adjoin inst (inst-write-dependents prev-inst))
+ (sset-delete prev-inst (segment-emittable-insts-sset segment)))
+ ;; And we can forget about remembering them, because
+ ;; depending on us is as good as depending on them.
+ (setf (svref (segment-writers segment) index) nil))
+ (push inst (svref (segment-writers segment) index)))))
(values))
;;; This routine is called by due to uses of the INST macro when the
(defun queue-inst (segment inst)
#!+sb-show-assem (format *trace-output* "~&queuing ~S~%" inst)
#!+sb-show-assem (format *trace-output*
- " reads ~S~% writes ~S~%"
- (sb!int:collect ((reads))
- (do-sset-elements (read
- (inst-read-dependencies inst))
- (reads read))
- (reads))
- (sb!int:collect ((writes))
- (do-sset-elements (write
- (inst-write-dependencies inst))
- (writes write))
- (writes)))
+ " reads ~S~% writes ~S~%"
+ (sb!int:collect ((reads))
+ (do-sset-elements (read
+ (inst-read-dependencies inst))
+ (reads read))
+ (reads))
+ (sb!int:collect ((writes))
+ (do-sset-elements (write
+ (inst-write-dependencies inst))
+ (writes write))
+ (writes)))
(aver (segment-run-scheduler segment))
(let ((countdown (segment-branch-countdown segment)))
(when countdown
(decf countdown)
(aver (not (instruction-attributep (inst-attributes inst)
- variable-length))))
+ variable-length))))
(cond ((instruction-attributep (inst-attributes inst) branch)
- (unless countdown
- (setf countdown (inst-delay inst)))
- (push (cons countdown inst)
- (segment-queued-branches segment)))
- (t
- (sset-adjoin inst (segment-emittable-insts-sset segment))))
+ (unless countdown
+ (setf countdown (inst-delay inst)))
+ (push (cons countdown inst)
+ (segment-queued-branches segment)))
+ (t
+ (sset-adjoin inst (segment-emittable-insts-sset segment))))
(when countdown
(setf (segment-branch-countdown segment) countdown)
(when (zerop countdown)
- (schedule-pending-instructions segment))))
+ (schedule-pending-instructions segment))))
(values))
;;; Emit all the pending instructions, and reset any state. This is
;; Quick blow-out if nothing to do.
(when (and (sset-empty (segment-emittable-insts-sset segment))
- (null (segment-queued-branches segment)))
+ (null (segment-queued-branches segment)))
(return-from schedule-pending-instructions
- (values)))
+ (values)))
#!+sb-show-assem (format *trace-output*
- "~&scheduling pending instructions..~%")
+ "~&scheduling pending instructions..~%")
;; Note that any values live at the end of the block have to be
;; computed last.
(let ((emittable-insts (segment-emittable-insts-sset segment))
- (writers (segment-writers segment)))
+ (writers (segment-writers segment)))
(dotimes (index (length writers))
(let* ((writer (svref writers index))
- (inst (car writer))
- (overwritten (cdr writer)))
- (when writer
- (when overwritten
- (let ((write-dependencies (inst-write-dependencies inst)))
- (dolist (other-inst overwritten)
- (sset-adjoin inst (inst-write-dependents other-inst))
- (sset-adjoin other-inst write-dependencies)
- (sset-delete other-inst emittable-insts))))
- ;; If the value is live at the end of the block, we can't flush it.
- (setf (instruction-attributep (inst-attributes inst) flushable)
- nil)))))
+ (inst (car writer))
+ (overwritten (cdr writer)))
+ (when writer
+ (when overwritten
+ (let ((write-dependencies (inst-write-dependencies inst)))
+ (dolist (other-inst overwritten)
+ (sset-adjoin inst (inst-write-dependents other-inst))
+ (sset-adjoin other-inst write-dependencies)
+ (sset-delete other-inst emittable-insts))))
+ ;; If the value is live at the end of the block, we can't flush it.
+ (setf (instruction-attributep (inst-attributes inst) flushable)
+ nil)))))
;; Grovel through the entire graph in the forward direction finding
;; all the leaf instructions.
(labels ((grovel-inst (inst)
- (let ((max 0))
- (do-sset-elements (dep (inst-write-dependencies inst))
- (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
- (when (> dep-depth max)
- (setf max dep-depth))))
- (do-sset-elements (dep (inst-read-dependencies inst))
- (let ((dep-depth
- (+ (or (inst-depth dep) (grovel-inst dep))
- (inst-delay dep))))
- (when (> dep-depth max)
- (setf max dep-depth))))
- (cond ((and (sset-empty (inst-read-dependents inst))
- (instruction-attributep (inst-attributes inst)
- flushable))
- #!+sb-show-assem (format *trace-output*
- "flushing ~S~%"
- inst)
- (setf (inst-emitter inst) nil)
- (setf (inst-depth inst) max))
- (t
- (setf (inst-depth inst) max))))))
+ (let ((max 0))
+ (do-sset-elements (dep (inst-write-dependencies inst))
+ (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
+ (when (> dep-depth max)
+ (setf max dep-depth))))
+ (do-sset-elements (dep (inst-read-dependencies inst))
+ (let ((dep-depth
+ (+ (or (inst-depth dep) (grovel-inst dep))
+ (inst-delay dep))))
+ (when (> dep-depth max)
+ (setf max dep-depth))))
+ (cond ((and (sset-empty (inst-read-dependents inst))
+ (instruction-attributep (inst-attributes inst)
+ flushable))
+ #!+sb-show-assem (format *trace-output*
+ "flushing ~S~%"
+ inst)
+ (setf (inst-emitter inst) nil)
+ (setf (inst-depth inst) max))
+ (t
+ (setf (inst-depth inst) max))))))
(let ((emittable-insts nil)
- (delayed nil))
+ (delayed nil))
(do-sset-elements (inst (segment-emittable-insts-sset segment))
- (grovel-inst inst)
- (if (zerop (inst-delay inst))
- (push inst emittable-insts)
- (setf delayed
- (add-to-nth-list delayed inst (1- (inst-delay inst))))))
+ (grovel-inst inst)
+ (if (zerop (inst-delay inst))
+ (push inst emittable-insts)
+ (setf delayed
+ (add-to-nth-list delayed inst (1- (inst-delay inst))))))
(setf (segment-emittable-insts-queue segment)
- (sort emittable-insts #'> :key #'inst-depth))
+ (sort emittable-insts #'> :key #'inst-depth))
(setf (segment-delayed segment) delayed))
(dolist (branch (segment-queued-branches segment))
(grovel-inst (cdr branch))))
#!+sb-show-assem (format *trace-output*
- "queued branches: ~S~%"
- (segment-queued-branches segment))
+ "queued branches: ~S~%"
+ (segment-queued-branches segment))
#!+sb-show-assem (format *trace-output*
- "initially emittable: ~S~%"
- (segment-emittable-insts-queue segment))
+ "initially emittable: ~S~%"
+ (segment-emittable-insts-queue segment))
#!+sb-show-assem (format *trace-output*
- "initially delayed: ~S~%"
- (segment-delayed segment))
+ "initially delayed: ~S~%"
+ (segment-delayed segment))
;; Accumulate the results in reverse order. Well, actually, this
;; list will be in forward order, because we are generating the
;; Schedule all the branches in their exact locations.
(let ((insts-from-end (segment-branch-countdown segment)))
(dolist (branch (segment-queued-branches segment))
- (let ((inst (cdr branch)))
- (dotimes (i (- (car branch) insts-from-end))
- ;; Each time through this loop we need to emit another
- ;; instruction. First, we check to see whether there is
- ;; any instruction that must be emitted before (i.e. must
- ;; come after) the branch inst. If so, emit it. Otherwise,
- ;; just pick one of the emittable insts. If there is
- ;; nothing to do, then emit a nop. ### Note: despite the
- ;; fact that this is a loop, it really won't work for
- ;; repetitions other then zero and one. For example, if
- ;; the branch has two dependents and one of them dpends on
- ;; the other, then the stuff that grabs a dependent could
- ;; easily grab the wrong one. But I don't feel like fixing
- ;; this because it doesn't matter for any of the
- ;; architectures we are using or plan on using.
- (flet ((maybe-schedule-dependent (dependents)
- (do-sset-elements (inst dependents)
- ;; If do-sset-elements enters the body, then there is a
- ;; dependent. Emit it.
- (note-resolved-dependencies segment inst)
- ;; Remove it from the emittable insts.
- (setf (segment-emittable-insts-queue segment)
- (delete inst
- (segment-emittable-insts-queue segment)
- :test #'eq))
- ;; And if it was delayed, removed it from the delayed
- ;; list. This can happen if there is a load in a
- ;; branch delay slot.
- (block scan-delayed
- (do ((delayed (segment-delayed segment)
- (cdr delayed)))
- ((null delayed))
- (do ((prev nil cons)
- (cons (car delayed) (cdr cons)))
- ((null cons))
- (when (eq (car cons) inst)
- (if prev
- (setf (cdr prev) (cdr cons))
- (setf (car delayed) (cdr cons)))
- (return-from scan-delayed nil)))))
- ;; And return it.
- (return inst))))
- (let ((fill (or (maybe-schedule-dependent
- (inst-read-dependents inst))
- (maybe-schedule-dependent
- (inst-write-dependents inst))
- (schedule-one-inst segment t)
- :nop)))
- #!+sb-show-assem (format *trace-output*
- "filling branch delay slot with ~S~%"
- fill)
- (push fill results)))
- (advance-one-inst segment)
- (incf insts-from-end))
- (note-resolved-dependencies segment inst)
- (push inst results)
- #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
- (advance-one-inst segment))))
+ (let ((inst (cdr branch)))
+ (dotimes (i (- (car branch) insts-from-end))
+ ;; Each time through this loop we need to emit another
+ ;; instruction. First, we check to see whether there is
+ ;; any instruction that must be emitted before (i.e. must
+ ;; come after) the branch inst. If so, emit it. Otherwise,
+ ;; just pick one of the emittable insts. If there is
+ ;; nothing to do, then emit a nop. ### Note: despite the
+ ;; fact that this is a loop, it really won't work for
+ ;; repetitions other then zero and one. For example, if
+ ;; the branch has two dependents and one of them dpends on
+ ;; the other, then the stuff that grabs a dependent could
+ ;; easily grab the wrong one. But I don't feel like fixing
+ ;; this because it doesn't matter for any of the
+ ;; architectures we are using or plan on using.
+ (flet ((maybe-schedule-dependent (dependents)
+ (do-sset-elements (inst dependents)
+ ;; If do-sset-elements enters the body, then there is a
+ ;; dependent. Emit it.
+ (note-resolved-dependencies segment inst)
+ ;; Remove it from the emittable insts.
+ (setf (segment-emittable-insts-queue segment)
+ (delete inst
+ (segment-emittable-insts-queue segment)
+ :test #'eq))
+ ;; And if it was delayed, removed it from the delayed
+ ;; list. This can happen if there is a load in a
+ ;; branch delay slot.
+ (block scan-delayed
+ (do ((delayed (segment-delayed segment)
+ (cdr delayed)))
+ ((null delayed))
+ (do ((prev nil cons)
+ (cons (car delayed) (cdr cons)))
+ ((null cons))
+ (when (eq (car cons) inst)
+ (if prev
+ (setf (cdr prev) (cdr cons))
+ (setf (car delayed) (cdr cons)))
+ (return-from scan-delayed nil)))))
+ ;; And return it.
+ (return inst))))
+ (let ((fill (or (maybe-schedule-dependent
+ (inst-read-dependents inst))
+ (maybe-schedule-dependent
+ (inst-write-dependents inst))
+ (schedule-one-inst segment t)
+ :nop)))
+ #!+sb-show-assem (format *trace-output*
+ "filling branch delay slot with ~S~%"
+ fill)
+ (push fill results)))
+ (advance-one-inst segment)
+ (incf insts-from-end))
+ (note-resolved-dependencies segment inst)
+ (push inst results)
+ #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
+ (advance-one-inst segment))))
;; Keep scheduling stuff until we run out.
(loop
(let ((inst (schedule-one-inst segment nil)))
- (unless inst
- (return))
- (push inst results)
- (advance-one-inst segment)))
+ (unless inst
+ (return))
+ (push inst results)
+ (advance-one-inst segment)))
;; Now call the emitters, but turn the scheduler off for the duration.
(setf (segment-run-scheduler segment) nil)
(dolist (inst results)
(if (eq inst :nop)
- (sb!c:emit-nop segment)
- (funcall (inst-emitter inst) segment)))
+ (sb!c:emit-nop segment)
+ (funcall (inst-emitter inst) segment)))
(setf (segment-run-scheduler segment) t))
;; Clear out any residue left over.
;;; into the car of that cons cell.
(defun add-to-nth-list (list thing n)
(do ((cell (or list (setf list (list nil)))
- (or (cdr cell) (setf (cdr cell) (list nil))))
+ (or (cdr cell) (setf (cdr cell) (list nil))))
(i n (1- i)))
((zerop i)
(push thing (car cell))
((null remaining))
(let ((inst (car remaining)))
(unless (and delay-slot-p
- (instruction-attributep (inst-attributes inst)
- variable-length))
- ;; We've got us a live one here. Go for it.
- #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
- ;; Delete it from the list of insts.
- (if prev
- (setf (cdr prev) (cdr remaining))
- (setf (segment-emittable-insts-queue segment)
- (cdr remaining)))
- ;; Note that this inst has been emitted.
- (note-resolved-dependencies segment inst)
- ;; And return.
- (return-from schedule-one-inst
- ;; Are we wanting to flush this instruction?
- (if (inst-emitter inst)
- ;; Nope, it's still a go. So return it.
- inst
- ;; Yes, so pick a new one. We have to start
- ;; over, because note-resolved-dependencies
- ;; might have changed the emittable-insts-queue.
- (schedule-one-inst segment delay-slot-p))))))
+ (instruction-attributep (inst-attributes inst)
+ variable-length))
+ ;; We've got us a live one here. Go for it.
+ #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
+ ;; Delete it from the list of insts.
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-emittable-insts-queue segment)
+ (cdr remaining)))
+ ;; Note that this inst has been emitted.
+ (note-resolved-dependencies segment inst)
+ ;; And return.
+ (return-from schedule-one-inst
+ ;; Are we wanting to flush this instruction?
+ (if (inst-emitter inst)
+ ;; Nope, it's still a go. So return it.
+ inst
+ ;; Yes, so pick a new one. We have to start
+ ;; over, because note-resolved-dependencies
+ ;; might have changed the emittable-insts-queue.
+ (schedule-one-inst segment delay-slot-p))))))
;; Nothing to do, so make something up.
(cond ((segment-delayed segment)
- ;; No emittable instructions, but we have more work to do. Emit
- ;; a NOP to fill in a delay slot.
- #!+sb-show-assem (format *trace-output* "emitting a NOP~%")
- :nop)
- (t
- ;; All done.
- nil)))
+ ;; No emittable instructions, but we have more work to do. Emit
+ ;; a NOP to fill in a delay slot.
+ #!+sb-show-assem (format *trace-output* "emitting a NOP~%")
+ :nop)
+ (t
+ ;; All done.
+ nil)))
;;; This function is called whenever an instruction has been
;;; scheduled, and we want to know what possibilities that opens up.
(let ((dependents (inst-write-dependents dep)))
(sset-delete inst dependents)
(when (and (sset-empty dependents)
- (sset-empty (inst-read-dependents dep)))
- (insert-emittable-inst segment dep))))
+ (sset-empty (inst-read-dependents dep)))
+ (insert-emittable-inst segment dep))))
(do-sset-elements (dep (inst-read-dependencies inst))
;; These are the instructions who write values we read. If there
;; is no delay, then just remove us from the dependent list.
;; Otherwise, record the fact that in n cycles, we should be
;; removed.
(if (zerop (inst-delay dep))
- (let ((dependents (inst-read-dependents dep)))
- (sset-delete inst dependents)
- (when (and (sset-empty dependents)
- (sset-empty (inst-write-dependents dep)))
- (insert-emittable-inst segment dep)))
- (setf (segment-delayed segment)
- (add-to-nth-list (segment-delayed segment)
- (cons dep inst)
- (inst-delay dep)))))
+ (let ((dependents (inst-read-dependents dep)))
+ (sset-delete inst dependents)
+ (when (and (sset-empty dependents)
+ (sset-empty (inst-write-dependents dep)))
+ (insert-emittable-inst segment dep)))
+ (setf (segment-delayed segment)
+ (add-to-nth-list (segment-delayed segment)
+ (cons dep inst)
+ (inst-delay dep)))))
(values))
;;; Process the next entry in segment-delayed. This is called whenever
(let ((delayed-stuff (pop (segment-delayed segment))))
(dolist (stuff delayed-stuff)
(if (consp stuff)
- (let* ((dependency (car stuff))
- (dependent (cdr stuff))
- (dependents (inst-read-dependents dependency)))
- (sset-delete dependent dependents)
- (when (and (sset-empty dependents)
- (sset-empty (inst-write-dependents dependency)))
- (insert-emittable-inst segment dependency)))
- (insert-emittable-inst segment stuff)))))
+ (let* ((dependency (car stuff))
+ (dependent (cdr stuff))
+ (dependents (inst-read-dependents dependency)))
+ (sset-delete dependent dependents)
+ (when (and (sset-empty dependents)
+ (sset-empty (inst-write-dependents dependency)))
+ (insert-emittable-inst segment dependency)))
+ (insert-emittable-inst segment stuff)))))
;;; Note that inst is emittable by sticking it in the
;;; SEGMENT-EMITTABLE-INSTS-QUEUE list. We keep the emittable-insts
(unless (instruction-attributep (inst-attributes inst) branch)
#!+sb-show-assem (format *trace-output* "now emittable: ~S~%" inst)
(do ((my-depth (inst-depth inst))
- (remaining (segment-emittable-insts-queue segment) (cdr remaining))
- (prev nil remaining))
- ((or (null remaining) (> my-depth (inst-depth (car remaining))))
- (if prev
- (setf (cdr prev) (cons inst remaining))
- (setf (segment-emittable-insts-queue segment)
- (cons inst remaining))))))
+ (remaining (segment-emittable-insts-queue segment) (cdr remaining))
+ (prev nil remaining))
+ ((or (null remaining) (> my-depth (inst-depth (car remaining))))
+ (if prev
+ (setf (cdr prev) (cons inst remaining))
+ (setf (segment-emittable-insts-queue segment)
+ (cons inst remaining))))))
(values))
\f
;;;; structure used during output emission
;;; common supertype for all the different kinds of annotations
(def!struct (annotation (:constructor nil)
- (:copier nil))
+ (:copier nil))
;; Where in the raw output stream was this annotation emitted?
(index 0 :type index)
;; What position does that correspond to?
(posn nil :type (or index null)))
(def!struct (label (:include annotation)
- (:constructor gen-label ())
- (:copier nil))
+ (:constructor gen-label ())
+ (:copier nil))
;; (doesn't need any additional information beyond what is in the
;; annotation structure)
)
(sb!int:def!method print-object ((label label) stream)
(if (or *print-escape* *print-readably*)
(print-unreadable-object (label stream :type t)
- (prin1 (sb!c:label-id label) stream))
+ (prin1 (sb!c:label-id label) stream))
(format stream "L~D" (sb!c:label-id label))))
;;; a constraint on how the output stream must be aligned
(def!struct (alignment-note (:include annotation)
- (:conc-name alignment-)
- (:predicate alignment-p)
- (:constructor make-alignment (bits size fill-byte))
- (:copier nil))
+ (:conc-name alignment-)
+ (:predicate alignment-p)
+ (:constructor make-alignment (bits size fill-byte))
+ (:copier nil))
;; the minimum number of low-order bits that must be zero
(bits 0 :type alignment)
;; the amount of filler we are assuming this alignment op will take
;;; a reference to someplace that needs to be back-patched when
;;; we actually know what label positions, etc. are
(def!struct (back-patch (:include annotation)
- (:constructor make-back-patch (size fun))
- (:copier nil))
+ (:constructor make-back-patch (size fun))
+ (:copier nil))
;; the area affected by this back-patch
(size 0 :type index :read-only t)
;; the function to use to generate the real data
;;; BACK-PATCHes can't change their mind about how much stuff to emit,
;;; but CHOOSERs can.
(def!struct (chooser (:include annotation)
- (:constructor make-chooser
- (size alignment maybe-shrink worst-case-fun))
- (:copier nil))
+ (:constructor make-chooser
+ (size alignment maybe-shrink worst-case-fun))
+ (:copier nil))
;; the worst case size for this chooser. There is this much space
;; allocated in the output buffer.
(size 0 :type index :read-only t)
;;; This is used internally when we figure out a chooser or alignment
;;; doesn't really need as much space as we initially gave it.
(def!struct (filler (:include annotation)
- (:constructor make-filler (bytes))
- (:copier nil))
+ (:constructor make-filler (bytes))
+ (:copier nil))
;; the number of bytes of filler here
(bytes 0 :type index))
\f
(declare (type segment segment))
(declare (type possibly-signed-assembly-unit byte))
(vector-push-extend (logand byte assembly-unit-mask)
- (segment-buffer segment))
+ (segment-buffer segment))
(incf (segment-current-posn segment))
(values))
;;; interface: Output AMOUNT copies of FILL-BYTE to SEGMENT.
(defun emit-skip (segment amount &optional (fill-byte 0))
(declare (type segment segment)
- (type index amount))
+ (type index amount))
(dotimes (i amount)
(emit-byte segment fill-byte))
(values))
;;; of SEGMENT's annotations list.
(defun emit-annotation (segment note)
(declare (type segment segment)
- (type annotation note))
+ (type annotation note))
(when (annotation-posn note)
(error "attempt to emit ~S a second time" note))
(setf (annotation-posn note) (segment-current-posn segment))
(setf (annotation-index note) (segment-current-index segment))
(let ((last (segment-last-annotation segment))
- (new (list note)))
+ (new (list note)))
(setf (segment-last-annotation segment)
- (if last
- (setf (cdr last) new)
- (setf (segment-annotations segment) new))))
+ (if last
+ (setf (cdr last) new)
+ (setf (segment-annotations segment) new))))
(values))
;;; Note that the instruction stream has to be back-patched when label
;;; BACK-PATCH. (See EMIT-BACK-PATCH.)
(defun emit-chooser (segment size alignment maybe-shrink worst-case-fun)
(declare (type segment segment) (type index size) (type alignment alignment)
- (type function maybe-shrink worst-case-fun))
+ (type function maybe-shrink worst-case-fun))
(let ((chooser (make-chooser size alignment maybe-shrink worst-case-fun)))
(emit-annotation segment chooser)
(emit-skip segment size)
(defun adjust-alignment-after-chooser (segment chooser)
(declare (type segment segment) (type chooser chooser))
(let ((alignment (chooser-alignment chooser))
- (seg-alignment (segment-alignment segment)))
+ (seg-alignment (segment-alignment segment)))
(when (< alignment seg-alignment)
;; The chooser might change the alignment of the output. So we
;; have to figure out what the worst case alignment could be.
(setf (segment-alignment segment) alignment)
(let* ((posn (chooser-posn chooser))
- (sync-posn (segment-sync-posn segment))
- (offset (- posn sync-posn))
- (delta (logand offset (1- (ash 1 alignment)))))
- (setf (segment-sync-posn segment) (- posn delta)))))
+ (sync-posn (segment-sync-posn segment))
+ (offset (- posn sync-posn))
+ (delta (logand offset (1- (ash 1 alignment)))))
+ (setf (segment-sync-posn segment) (- posn delta)))))
(values))
;;; This is used internally whenever a chooser or alignment decides it
(declare (type index n-bytes))
(let ((last (segment-last-annotation segment)))
(cond ((and last (filler-p (car last)))
- (incf (filler-bytes (car last)) n-bytes))
- (t
- (emit-annotation segment (make-filler n-bytes)))))
+ (incf (filler-bytes (car last)) n-bytes))
+ (t
+ (emit-annotation segment (make-filler n-bytes)))))
(incf (segment-current-index segment) n-bytes)
(values))
(when hook
(funcall hook segment vop :align bits)))
(let ((alignment (segment-alignment segment))
- (offset (- (segment-current-posn segment)
- (segment-sync-posn segment))))
+ (offset (- (segment-current-posn segment)
+ (segment-sync-posn segment))))
(cond ((> bits alignment)
- ;; We need more bits of alignment. First emit enough noise
- ;; to get back in sync with alignment, and then emit an
- ;; alignment note to cover the rest.
- (let ((slop (logand offset (1- (ash 1 alignment)))))
- (unless (zerop slop)
- (emit-skip segment (- (ash 1 alignment) slop) fill-byte)))
- (let ((size (logand (1- (ash 1 bits))
- (lognot (1- (ash 1 alignment))))))
- (aver (> size 0))
- (emit-annotation segment (make-alignment bits size fill-byte))
- (emit-skip segment size fill-byte))
- (setf (segment-alignment segment) bits)
- (setf (segment-sync-posn segment) (segment-current-posn segment)))
- (t
- ;; The last alignment was more restrictive then this one.
- ;; So we can just figure out how much noise to emit
- ;; assuming the last alignment was met.
- (let* ((mask (1- (ash 1 bits)))
- (new-offset (logand (+ offset mask) (lognot mask))))
- (emit-skip segment (- new-offset offset) fill-byte))
- ;; But we emit an alignment with size=0 so we can verify
- ;; that everything works.
- (emit-annotation segment (make-alignment bits 0 fill-byte)))))
+ ;; We need more bits of alignment. First emit enough noise
+ ;; to get back in sync with alignment, and then emit an
+ ;; alignment note to cover the rest.
+ (let ((slop (logand offset (1- (ash 1 alignment)))))
+ (unless (zerop slop)
+ (emit-skip segment (- (ash 1 alignment) slop) fill-byte)))
+ (let ((size (logand (1- (ash 1 bits))
+ (lognot (1- (ash 1 alignment))))))
+ (aver (> size 0))
+ (emit-annotation segment (make-alignment bits size fill-byte))
+ (emit-skip segment size fill-byte))
+ (setf (segment-alignment segment) bits)
+ (setf (segment-sync-posn segment) (segment-current-posn segment)))
+ (t
+ ;; The last alignment was more restrictive then this one.
+ ;; So we can just figure out how much noise to emit
+ ;; assuming the last alignment was met.
+ (let* ((mask (1- (ash 1 bits)))
+ (new-offset (logand (+ offset mask) (lognot mask))))
+ (emit-skip segment (- new-offset offset) fill-byte))
+ ;; But we emit an alignment with size=0 so we can verify
+ ;; that everything works.
+ (emit-annotation segment (make-alignment bits 0 fill-byte)))))
(values))
;;; This is used to find how ``aligned'' different offsets are.
(setf (segment-alignment segment) max-alignment)
(setf (segment-sync-posn segment) 0)
(do* ((prev nil)
- (remaining (segment-annotations segment) next)
- (next (cdr remaining) (cdr remaining)))
- ((null remaining))
- (let* ((note (car remaining))
- (posn (annotation-posn note)))
- (unless (zerop delta)
- (decf posn delta)
- (setf (annotation-posn note) posn))
- (cond
- ((chooser-p note)
- (with-modified-segment-index-and-posn (segment (chooser-index note)
- posn)
- (setf (segment-last-annotation segment) prev)
- (cond
- ((funcall (chooser-maybe-shrink note) segment posn delta)
- ;; It emitted some replacement.
- (let ((new-size (- (segment-current-index segment)
- (chooser-index note)))
- (old-size (chooser-size note)))
- (when (> new-size old-size)
- (error "~S emitted ~W bytes, but claimed its max was ~W."
- note new-size old-size))
- (let ((additional-delta (- old-size new-size)))
- (when (< (find-alignment additional-delta)
- (chooser-alignment note))
- (error "~S shrunk by ~W bytes, but claimed that it ~
+ (remaining (segment-annotations segment) next)
+ (next (cdr remaining) (cdr remaining)))
+ ((null remaining))
+ (let* ((note (car remaining))
+ (posn (annotation-posn note)))
+ (unless (zerop delta)
+ (decf posn delta)
+ (setf (annotation-posn note) posn))
+ (cond
+ ((chooser-p note)
+ (with-modified-segment-index-and-posn (segment (chooser-index note)
+ posn)
+ (setf (segment-last-annotation segment) prev)
+ (cond
+ ((funcall (chooser-maybe-shrink note) segment posn delta)
+ ;; It emitted some replacement.
+ (let ((new-size (- (segment-current-index segment)
+ (chooser-index note)))
+ (old-size (chooser-size note)))
+ (when (> new-size old-size)
+ (error "~S emitted ~W bytes, but claimed its max was ~W."
+ note new-size old-size))
+ (let ((additional-delta (- old-size new-size)))
+ (when (< (find-alignment additional-delta)
+ (chooser-alignment note))
+ (error "~S shrunk by ~W bytes, but claimed that it ~
preserves ~W bits of alignment."
- note additional-delta (chooser-alignment note)))
- (incf delta additional-delta)
- (emit-filler segment additional-delta))
- (setf prev (segment-last-annotation segment))
- (if prev
- (setf (cdr prev) (cdr remaining))
- (setf (segment-annotations segment)
- (cdr remaining)))))
- (t
- ;; The chooser passed on shrinking. Make sure it didn't
- ;; emit anything.
- (unless (= (segment-current-index segment)
- (chooser-index note))
- (error "Chooser ~S passed, but not before emitting ~W bytes."
- note
- (- (segment-current-index segment)
- (chooser-index note))))
- ;; Act like we just emitted this chooser.
- (let ((size (chooser-size note)))
- (incf (segment-current-index segment) size)
- (incf (segment-current-posn segment) size))
- ;; Adjust the alignment accordingly.
- (adjust-alignment-after-chooser segment note)
- ;; And keep this chooser for next time around.
- (setf prev remaining)))))
- ((alignment-p note)
- (unless (zerop (alignment-size note))
- ;; Re-emit the alignment, letting it collapse if we know
- ;; anything more about the alignment guarantees of the
- ;; segment.
- (let ((index (alignment-index note)))
- (with-modified-segment-index-and-posn (segment index posn)
- (setf (segment-last-annotation segment) prev)
- (emit-alignment segment nil (alignment-bits note)
- (alignment-fill-byte note))
- (let* ((new-index (segment-current-index segment))
- (size (- new-index index))
- (old-size (alignment-size note))
- (additional-delta (- old-size size)))
- (when (minusp additional-delta)
- (error "Alignment ~S needs more space now? It was ~W, ~
+ note additional-delta (chooser-alignment note)))
+ (incf delta additional-delta)
+ (emit-filler segment additional-delta))
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-annotations segment)
+ (cdr remaining)))))
+ (t
+ ;; The chooser passed on shrinking. Make sure it didn't
+ ;; emit anything.
+ (unless (= (segment-current-index segment)
+ (chooser-index note))
+ (error "Chooser ~S passed, but not before emitting ~W bytes."
+ note
+ (- (segment-current-index segment)
+ (chooser-index note))))
+ ;; Act like we just emitted this chooser.
+ (let ((size (chooser-size note)))
+ (incf (segment-current-index segment) size)
+ (incf (segment-current-posn segment) size))
+ ;; Adjust the alignment accordingly.
+ (adjust-alignment-after-chooser segment note)
+ ;; And keep this chooser for next time around.
+ (setf prev remaining)))))
+ ((alignment-p note)
+ (unless (zerop (alignment-size note))
+ ;; Re-emit the alignment, letting it collapse if we know
+ ;; anything more about the alignment guarantees of the
+ ;; segment.
+ (let ((index (alignment-index note)))
+ (with-modified-segment-index-and-posn (segment index posn)
+ (setf (segment-last-annotation segment) prev)
+ (emit-alignment segment nil (alignment-bits note)
+ (alignment-fill-byte note))
+ (let* ((new-index (segment-current-index segment))
+ (size (- new-index index))
+ (old-size (alignment-size note))
+ (additional-delta (- old-size size)))
+ (when (minusp additional-delta)
+ (error "Alignment ~S needs more space now? It was ~W, ~
and is ~W now."
- note old-size size))
- (when (plusp additional-delta)
- (emit-filler segment additional-delta)
- (incf delta additional-delta)))
- (setf prev (segment-last-annotation segment))
- (if prev
- (setf (cdr prev) (cdr remaining))
- (setf (segment-annotations segment)
- (cdr remaining)))))))
- (t
- (setf prev remaining)))))
+ note old-size size))
+ (when (plusp additional-delta)
+ (emit-filler segment additional-delta)
+ (incf delta additional-delta)))
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-annotations segment)
+ (cdr remaining)))))))
+ (t
+ (setf prev remaining)))))
(when (zerop delta)
- (return))
+ (return))
(decf (segment-final-posn segment) delta)))
(values))
(defun finalize-positions (segment)
(let ((delta 0))
(do* ((prev nil)
- (remaining (segment-annotations segment) next)
- (next (cdr remaining) (cdr remaining)))
- ((null remaining))
+ (remaining (segment-annotations segment) next)
+ (next (cdr remaining) (cdr remaining)))
+ ((null remaining))
(let* ((note (car remaining))
- (posn (- (annotation-posn note) delta)))
- (cond
- ((alignment-p note)
- (let* ((bits (alignment-bits note))
- (mask (1- (ash 1 bits)))
- (new-posn (logand (+ posn mask) (lognot mask)))
- (size (- new-posn posn))
- (old-size (alignment-size note))
- (additional-delta (- old-size size)))
- (aver (<= 0 size old-size))
- (unless (zerop additional-delta)
- (setf (segment-last-annotation segment) prev)
- (incf delta additional-delta)
- (with-modified-segment-index-and-posn (segment
- (alignment-index note)
- posn)
- (emit-filler segment additional-delta)
- (setf prev (segment-last-annotation segment))
- (if prev
- (setf (cdr prev) next)
- (setf (segment-annotations segment) next))))))
- (t
- (setf (annotation-posn note) posn)
- (setf prev remaining)
- (setf next (cdr remaining))))))
+ (posn (- (annotation-posn note) delta)))
+ (cond
+ ((alignment-p note)
+ (let* ((bits (alignment-bits note))
+ (mask (1- (ash 1 bits)))
+ (new-posn (logand (+ posn mask) (lognot mask)))
+ (size (- new-posn posn))
+ (old-size (alignment-size note))
+ (additional-delta (- old-size size)))
+ (aver (<= 0 size old-size))
+ (unless (zerop additional-delta)
+ (setf (segment-last-annotation segment) prev)
+ (incf delta additional-delta)
+ (with-modified-segment-index-and-posn (segment
+ (alignment-index note)
+ posn)
+ (emit-filler segment additional-delta)
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) next)
+ (setf (segment-annotations segment) next))))))
+ (t
+ (setf (annotation-posn note) posn)
+ (setf prev remaining)
+ (setf next (cdr remaining))))))
(unless (zerop delta)
(decf (segment-final-posn segment) delta)))
(values))
;;; are left over, we need to emit their worst case varient.
(defun process-back-patches (segment)
(do* ((prev nil)
- (remaining (segment-annotations segment) next)
- (next (cdr remaining) (cdr remaining)))
+ (remaining (segment-annotations segment) next)
+ (next (cdr remaining) (cdr remaining)))
((null remaining))
(let ((note (car remaining)))
(flet ((fill-in (function old-size)
- (let ((index (annotation-index note))
- (posn (annotation-posn note)))
- (with-modified-segment-index-and-posn (segment index posn)
- (setf (segment-last-annotation segment) prev)
- (funcall function segment posn)
- (let ((new-size (- (segment-current-index segment) index)))
- (unless (= new-size old-size)
- (error "~S emitted ~W bytes, but claimed it was ~W."
- note new-size old-size)))
- (let ((tail (segment-last-annotation segment)))
- (if tail
- (setf (cdr tail) next)
- (setf (segment-annotations segment) next)))
- (setf next (cdr prev))))))
- (cond ((back-patch-p note)
- (fill-in (back-patch-fun note)
- (back-patch-size note)))
- ((chooser-p note)
- (fill-in (chooser-worst-case-fun note)
- (chooser-size note)))
- (t
- (setf prev remaining)))))))
+ (let ((index (annotation-index note))
+ (posn (annotation-posn note)))
+ (with-modified-segment-index-and-posn (segment index posn)
+ (setf (segment-last-annotation segment) prev)
+ (funcall function segment posn)
+ (let ((new-size (- (segment-current-index segment) index)))
+ (unless (= new-size old-size)
+ (error "~S emitted ~W bytes, but claimed it was ~W."
+ note new-size old-size)))
+ (let ((tail (segment-last-annotation segment)))
+ (if tail
+ (setf (cdr tail) next)
+ (setf (segment-annotations segment) next)))
+ (setf next (cdr prev))))))
+ (cond ((back-patch-p note)
+ (fill-in (back-patch-fun note)
+ (back-patch-size note)))
+ ((chooser-p note)
+ (fill-in (chooser-worst-case-fun note)
+ (chooser-size note)))
+ (t
+ (setf prev remaining)))))))
\f
;;;; interface to the rest of the compiler
;;; hunt for good solutions until the system works and I can test them
;;; in isolation.
(sb!int:def!macro assemble ((&optional segment vop &key labels) &body body
- &environment env)
+ &environment env)
#!+sb-doc
"Execute BODY (as a progn) with SEGMENT as the current segment."
(flet ((label-name-p (thing)
- (and thing (symbolp thing))))
+ (and thing (symbolp thing))))
(let* ((seg-var (gensym "SEGMENT-"))
- (vop-var (gensym "VOP-"))
- (visible-labels (remove-if-not #'label-name-p body))
- (inherited-labels
- (multiple-value-bind (expansion expanded)
- (macroexpand '..inherited-labels.. env)
- (if expanded expansion nil)))
- (new-labels (append labels
- (set-difference visible-labels
- inherited-labels)))
- (nested-labels (set-difference (append inherited-labels new-labels)
- visible-labels)))
+ (vop-var (gensym "VOP-"))
+ (visible-labels (remove-if-not #'label-name-p body))
+ (inherited-labels
+ (multiple-value-bind (expansion expanded)
+ (macroexpand '..inherited-labels.. env)
+ (if expanded expansion nil)))
+ (new-labels (append labels
+ (set-difference visible-labels
+ inherited-labels)))
+ (nested-labels (set-difference (append inherited-labels new-labels)
+ visible-labels)))
(when (intersection labels inherited-labels)
- (error "duplicate nested labels: ~S"
- (intersection labels inherited-labels)))
+ (error "duplicate nested labels: ~S"
+ (intersection labels inherited-labels)))
`(let* ((,seg-var ,(or segment '(%%current-segment%%)))
- (,vop-var ,(or vop '(%%current-vop%%)))
+ (,vop-var ,(or vop '(%%current-vop%%)))
,@(when segment
`((**current-segment** ,seg-var)))
,@(when vop
`((**current-vop** ,vop-var)))
- ,@(mapcar (lambda (name)
- `(,name (gen-label)))
- new-labels))
- (declare (ignorable ,vop-var ,seg-var)
- ;; Must be done so that contribs and user code doing
- ;; low-level stuff don't need to worry about this.
- (disable-package-locks %%current-segment%% %%current-vop%%))
- (macrolet ((%%current-segment%% () '**current-segment**)
- (%%current-vop%% () '**current-vop**))
+ ,@(mapcar (lambda (name)
+ `(,name (gen-label)))
+ new-labels))
+ (declare (ignorable ,vop-var ,seg-var)
+ ;; Must be done so that contribs and user code doing
+ ;; low-level stuff don't need to worry about this.
+ (disable-package-locks %%current-segment%% %%current-vop%%))
+ (macrolet ((%%current-segment%% () '**current-segment**)
+ (%%current-vop%% () '**current-vop**))
;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
;; can't deal with this declaration, so disable it on host.
;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration.
#-sb-xc-host
- (declare (enable-package-locks %%current-segment%% %%current-vop%%))
- (symbol-macrolet (,@(when (or inherited-labels nested-labels)
- `((..inherited-labels.. ,nested-labels))))
- ,@(mapcar (lambda (form)
- (if (label-name-p form)
- `(emit-label ,form)
- form))
- body)))))))
+ (declare (enable-package-locks %%current-segment%% %%current-vop%%))
+ (symbol-macrolet (,@(when (or inherited-labels nested-labels)
+ `((..inherited-labels.. ,nested-labels))))
+ ,@(mapcar (lambda (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
+ body)))))))
#+sb-xc-host
(sb!xc:defmacro assemble ((&optional segment vop &key labels)
- &body body
- &environment env)
+ &body body
+ &environment env)
#!+sb-doc
"Execute BODY (as a progn) with SEGMENT as the current segment."
(flet ((label-name-p (thing)
- (and thing (symbolp thing))))
+ (and thing (symbolp thing))))
(let* ((seg-var (gensym "SEGMENT-"))
- (vop-var (gensym "VOP-"))
- (visible-labels (remove-if-not #'label-name-p body))
- (inherited-labels
- (multiple-value-bind
- (expansion expanded)
- (sb!xc:macroexpand '..inherited-labels.. env)
- (if expanded expansion nil)))
- (new-labels (append labels
- (set-difference visible-labels
- inherited-labels)))
- (nested-labels (set-difference (append inherited-labels new-labels)
- visible-labels)))
+ (vop-var (gensym "VOP-"))
+ (visible-labels (remove-if-not #'label-name-p body))
+ (inherited-labels
+ (multiple-value-bind
+ (expansion expanded)
+ (sb!xc:macroexpand '..inherited-labels.. env)
+ (if expanded expansion nil)))
+ (new-labels (append labels
+ (set-difference visible-labels
+ inherited-labels)))
+ (nested-labels (set-difference (append inherited-labels new-labels)
+ visible-labels)))
(when (intersection labels inherited-labels)
- (error "duplicate nested labels: ~S"
- (intersection labels inherited-labels)))
+ (error "duplicate nested labels: ~S"
+ (intersection labels inherited-labels)))
`(let* ((,seg-var ,(or segment '(%%current-segment%%)))
- (,vop-var ,(or vop '(%%current-vop%%)))
+ (,vop-var ,(or vop '(%%current-vop%%)))
,@(when segment
`((**current-segment** ,seg-var)))
,@(when vop
`((**current-vop** ,vop-var)))
- ,@(mapcar (lambda (name)
- `(,name (gen-label)))
- new-labels))
- (declare (ignorable ,vop-var ,seg-var))
- (macrolet ((%%current-segment%% () '**current-segment**)
- (%%current-vop%% () '**current-vop**))
- (symbol-macrolet (,@(when (or inherited-labels nested-labels)
- `((..inherited-labels.. ,nested-labels))))
- ,@(mapcar (lambda (form)
- (if (label-name-p form)
- `(emit-label ,form)
- form))
- body)))))))
+ ,@(mapcar (lambda (name)
+ `(,name (gen-label)))
+ new-labels))
+ (declare (ignorable ,vop-var ,seg-var))
+ (macrolet ((%%current-segment%% () '**current-segment**)
+ (%%current-vop%% () '**current-vop**))
+ (symbol-macrolet (,@(when (or inherited-labels nested-labels)
+ `((..inherited-labels.. ,nested-labels))))
+ ,@(mapcar (lambda (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
+ body)))))))
(defmacro inst (&whole whole instruction &rest args &environment env)
#!+sb-doc
"Emit the specified instruction to the current segment."
(let ((inst (gethash (symbol-name instruction) *assem-instructions*)))
(cond ((null inst)
- (error "unknown instruction: ~S" instruction))
- ((functionp inst)
- (funcall inst (cdr whole) env))
- (t
- `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
+ (error "unknown instruction: ~S" instruction))
+ ((functionp inst)
+ (funcall inst (cdr whole) env))
+ (t
+ `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
;;; Note: The need to capture MACROLET bindings of %%CURRENT-SEGMENT%%
;;; and %%CURRENT-VOP%% prevents this from being an ordinary function.
should supply IF-AFTER and DELTA in order to ensure correct results."
(let ((posn (label-posn label)))
(if (and if-after (> posn if-after))
- (- posn delta)
- posn)))
+ (- posn delta)
+ posn)))
(defun append-segment (segment other-segment)
#!+sb-doc
(emit-back-patch segment 0 postit)))
(emit-alignment segment nil max-alignment #!+(or x86-64 x86) #x90)
(let ((segment-current-index-0 (segment-current-index segment))
- (segment-current-posn-0 (segment-current-posn segment)))
+ (segment-current-posn-0 (segment-current-posn segment)))
(incf (segment-current-index segment)
- (segment-current-index other-segment))
+ (segment-current-index other-segment))
(replace (segment-buffer segment)
- (segment-buffer other-segment)
- :start1 segment-current-index-0)
+ (segment-buffer other-segment)
+ :start1 segment-current-index-0)
(setf (segment-buffer other-segment) nil) ; to prevent accidental reuse
(incf (segment-current-posn segment)
- (segment-current-posn other-segment))
+ (segment-current-posn other-segment))
(let ((other-annotations (segment-annotations other-segment)))
(when other-annotations
- (dolist (note other-annotations)
- (incf (annotation-index note) segment-current-index-0)
- (incf (annotation-posn note) segment-current-posn-0))
- ;; This SEGMENT-LAST-ANNOTATION code is confusing. Is it really
- ;; worth enough in efficiency to justify it? -- WHN 19990322
- (let ((last (segment-last-annotation segment)))
- (if last
- (setf (cdr last) other-annotations)
- (setf (segment-annotations segment) other-annotations)))
- (setf (segment-last-annotation segment)
- (segment-last-annotation other-segment)))))
+ (dolist (note other-annotations)
+ (incf (annotation-index note) segment-current-index-0)
+ (incf (annotation-posn note) segment-current-posn-0))
+ ;; This SEGMENT-LAST-ANNOTATION code is confusing. Is it really
+ ;; worth enough in efficiency to justify it? -- WHN 19990322
+ (let ((last (segment-last-annotation segment)))
+ (if last
+ (setf (cdr last) other-annotations)
+ (setf (segment-annotations segment) other-annotations)))
+ (setf (segment-last-annotation segment)
+ (segment-last-annotation other-segment)))))
(values))
(defun finalize-segment (segment)
(defun on-segment-contents-vectorly (segment function)
(declare (type function function))
(let ((buffer (segment-buffer segment))
- (i0 0))
+ (i0 0))
(flet ((frob (i0 i1)
- (when (< i0 i1)
- (funcall function (subseq buffer i0 i1)))))
+ (when (< i0 i1)
+ (funcall function (subseq buffer i0 i1)))))
(dolist (note (segment-annotations segment))
- (when (filler-p note)
- (let ((i1 (filler-index note)))
- (frob i0 i1)
- (setf i0 (+ i1 (filler-bytes note))))))
+ (when (filler-p note)
+ (let ((i1 (filler-index note)))
+ (frob i0 i1)
+ (setf i0 (+ i1 (filler-bytes note))))))
(frob i0 (segment-final-index segment))))
(values))
(let ((result 0))
(declare (type index result))
(on-segment-contents-vectorly segment
- (lambda (v)
- (declare (type (vector assembly-unit) v))
- (incf result (length v))
- (write-sequence v stream)))
+ (lambda (v)
+ (declare (type (vector assembly-unit) v))
+ (incf result (length v))
+ (write-sequence v stream)))
result))
\f
;;;; interface to the instruction set definition
(defmacro define-bitfield-emitter (name total-bits &rest byte-specs)
(sb!int:collect ((arg-names) (arg-types))
(let* ((total-bits (eval total-bits))
- (overall-mask (ash -1 total-bits))
- (num-bytes (multiple-value-bind (quo rem)
- (truncate total-bits assembly-unit-bits)
- (unless (zerop rem)
- (error "~W isn't an even multiple of ~W."
- total-bits assembly-unit-bits))
- quo))
- (bytes (make-array num-bytes :initial-element nil))
- (segment-arg (gensym "SEGMENT-")))
+ (overall-mask (ash -1 total-bits))
+ (num-bytes (multiple-value-bind (quo rem)
+ (truncate total-bits assembly-unit-bits)
+ (unless (zerop rem)
+ (error "~W isn't an even multiple of ~W."
+ total-bits assembly-unit-bits))
+ quo))
+ (bytes (make-array num-bytes :initial-element nil))
+ (segment-arg (gensym "SEGMENT-")))
(dolist (byte-spec-expr byte-specs)
- (let* ((byte-spec (eval byte-spec-expr))
- (byte-size (byte-size byte-spec))
- (byte-posn (byte-position byte-spec))
- (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
- (when (ldb-test (byte byte-size byte-posn) overall-mask)
- (error "The byte spec ~S either overlaps another byte spec, or ~
+ (let* ((byte-spec (eval byte-spec-expr))
+ (byte-size (byte-size byte-spec))
+ (byte-posn (byte-position byte-spec))
+ (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
+ (when (ldb-test (byte byte-size byte-posn) overall-mask)
+ (error "The byte spec ~S either overlaps another byte spec, or ~
extends past the end."
- byte-spec-expr))
- (setf (ldb byte-spec overall-mask) -1)
- (arg-names arg)
- (arg-types `(type (integer ,(ash -1 (1- byte-size))
- ,(1- (ash 1 byte-size)))
- ,arg))
- (multiple-value-bind (start-byte offset)
- (floor byte-posn assembly-unit-bits)
- (let ((end-byte (floor (1- (+ byte-posn byte-size))
- assembly-unit-bits)))
- (flet ((maybe-ash (expr offset)
- (if (zerop offset)
- expr
- `(ash ,expr ,offset))))
- (declare (inline maybe-ash))
- (cond ((zerop byte-size))
- ((= start-byte end-byte)
- (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg)
- offset)
- (svref bytes start-byte)))
- (t
- (push (maybe-ash
- `(ldb (byte ,(- assembly-unit-bits offset) 0)
- ,arg)
- offset)
- (svref bytes start-byte))
- (do ((index (1+ start-byte) (1+ index)))
- ((>= index end-byte))
- (push
- `(ldb (byte ,assembly-unit-bits
- ,(- (* assembly-unit-bits
- (- index start-byte))
- offset))
- ,arg)
- (svref bytes index)))
- (let ((len (rem (+ byte-size offset)
- assembly-unit-bits)))
- (push
- `(ldb (byte ,(if (zerop len)
- assembly-unit-bits
- len)
- ,(- (* assembly-unit-bits
- (- end-byte start-byte))
- offset))
- ,arg)
- (svref bytes end-byte))))))))))
+ byte-spec-expr))
+ (setf (ldb byte-spec overall-mask) -1)
+ (arg-names arg)
+ (arg-types `(type (integer ,(ash -1 (1- byte-size))
+ ,(1- (ash 1 byte-size)))
+ ,arg))
+ (multiple-value-bind (start-byte offset)
+ (floor byte-posn assembly-unit-bits)
+ (let ((end-byte (floor (1- (+ byte-posn byte-size))
+ assembly-unit-bits)))
+ (flet ((maybe-ash (expr offset)
+ (if (zerop offset)
+ expr
+ `(ash ,expr ,offset))))
+ (declare (inline maybe-ash))
+ (cond ((zerop byte-size))
+ ((= start-byte end-byte)
+ (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg)
+ offset)
+ (svref bytes start-byte)))
+ (t
+ (push (maybe-ash
+ `(ldb (byte ,(- assembly-unit-bits offset) 0)
+ ,arg)
+ offset)
+ (svref bytes start-byte))
+ (do ((index (1+ start-byte) (1+ index)))
+ ((>= index end-byte))
+ (push
+ `(ldb (byte ,assembly-unit-bits
+ ,(- (* assembly-unit-bits
+ (- index start-byte))
+ offset))
+ ,arg)
+ (svref bytes index)))
+ (let ((len (rem (+ byte-size offset)
+ assembly-unit-bits)))
+ (push
+ `(ldb (byte ,(if (zerop len)
+ assembly-unit-bits
+ len)
+ ,(- (* assembly-unit-bits
+ (- end-byte start-byte))
+ offset))
+ ,arg)
+ (svref bytes end-byte))))))))))
(unless (= overall-mask -1)
- (error "There are holes."))
+ (error "There are holes."))
(let ((forms nil))
- (dotimes (i num-bytes)
- (let ((pieces (svref bytes i)))
- (aver pieces)
- (push `(emit-byte ,segment-arg
- ,(if (cdr pieces)
- `(logior ,@pieces)
- (car pieces)))
- forms)))
- `(defun ,name (,segment-arg ,@(arg-names))
- (declare (type segment ,segment-arg) ,@(arg-types))
- ,@(ecase sb!c:*backend-byte-order*
- (:little-endian (nreverse forms))
- (:big-endian forms))
- ',name)))))
+ (dotimes (i num-bytes)
+ (let ((pieces (svref bytes i)))
+ (aver pieces)
+ (push `(emit-byte ,segment-arg
+ ,(if (cdr pieces)
+ `(logior ,@pieces)
+ (car pieces)))
+ forms)))
+ `(defun ,name (,segment-arg ,@(arg-names))
+ (declare (type segment ,segment-arg) ,@(arg-types))
+ ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian (nreverse forms))
+ (:big-endian forms))
+ ',name)))))
(defun grovel-lambda-list (lambda-list vop-var)
(let ((segment-name (car lambda-list))
- (vop-var (or vop-var (gensym "VOP-"))))
+ (vop-var (or vop-var (gensym "VOP-"))))
(sb!int:collect ((new-lambda-list))
(new-lambda-list segment-name)
(new-lambda-list vop-var)
(labels
- ((grovel (state lambda-list)
- (when lambda-list
- (let ((param (car lambda-list)))
- (cond
- ((member param sb!xc:lambda-list-keywords)
- (new-lambda-list param)
- (grovel param (cdr lambda-list)))
- (t
- (ecase state
- ((nil)
- (new-lambda-list param)
- `(cons ,param ,(grovel state (cdr lambda-list))))
- (&optional
- (multiple-value-bind (name default supplied-p)
- (if (consp param)
- (values (first param)
- (second param)
- (or (third param)
- (gensym "SUPPLIED-P-")))
- (values param nil (gensym "SUPPLIED-P-")))
- (new-lambda-list (list name default supplied-p))
- `(and ,supplied-p
- (cons ,(if (consp name)
- (second name)
- name)
- ,(grovel state (cdr lambda-list))))))
- (&key
- (multiple-value-bind (name default supplied-p)
- (if (consp param)
- (values (first param)
- (second param)
- (or (third param)
- (gensym "SUPPLIED-P-")))
- (values param nil (gensym "SUPPLIED-P-")))
- (new-lambda-list (list name default supplied-p))
- (multiple-value-bind (key var)
- (if (consp name)
- (values (first name) (second name))
- (values (keywordicate name) name))
- `(append (and ,supplied-p (list ',key ,var))
- ,(grovel state (cdr lambda-list))))))
- (&rest
- (new-lambda-list param)
- (grovel state (cdr lambda-list))
- param))))))))
- (let ((reconstructor (grovel nil (cdr lambda-list))))
- (values (new-lambda-list)
- segment-name
- vop-var
- reconstructor))))))
+ ((grovel (state lambda-list)
+ (when lambda-list
+ (let ((param (car lambda-list)))
+ (cond
+ ((member param sb!xc:lambda-list-keywords)
+ (new-lambda-list param)
+ (grovel param (cdr lambda-list)))
+ (t
+ (ecase state
+ ((nil)
+ (new-lambda-list param)
+ `(cons ,param ,(grovel state (cdr lambda-list))))
+ (&optional
+ (multiple-value-bind (name default supplied-p)
+ (if (consp param)
+ (values (first param)
+ (second param)
+ (or (third param)
+ (gensym "SUPPLIED-P-")))
+ (values param nil (gensym "SUPPLIED-P-")))
+ (new-lambda-list (list name default supplied-p))
+ `(and ,supplied-p
+ (cons ,(if (consp name)
+ (second name)
+ name)
+ ,(grovel state (cdr lambda-list))))))
+ (&key
+ (multiple-value-bind (name default supplied-p)
+ (if (consp param)
+ (values (first param)
+ (second param)
+ (or (third param)
+ (gensym "SUPPLIED-P-")))
+ (values param nil (gensym "SUPPLIED-P-")))
+ (new-lambda-list (list name default supplied-p))
+ (multiple-value-bind (key var)
+ (if (consp name)
+ (values (first name) (second name))
+ (values (keywordicate name) name))
+ `(append (and ,supplied-p (list ',key ,var))
+ ,(grovel state (cdr lambda-list))))))
+ (&rest
+ (new-lambda-list param)
+ (grovel state (cdr lambda-list))
+ param))))))))
+ (let ((reconstructor (grovel nil (cdr lambda-list))))
+ (values (new-lambda-list)
+ segment-name
+ vop-var
+ reconstructor))))))
(defun extract-nths (index glue list-of-lists-of-lists)
(mapcar (lambda (list-of-lists)
- (cons glue
- (mapcar (lambda (list)
- (nth index list))
- list-of-lists)))
- list-of-lists-of-lists))
+ (cons glue
+ (mapcar (lambda (list)
+ (nth index list))
+ list-of-lists)))
+ list-of-lists-of-lists))
(defmacro define-instruction (name lambda-list &rest options)
(let* ((sym-name (symbol-name name))
- (defun-name (sb!int:symbolicate sym-name "-INST-EMITTER"))
- (vop-var nil)
- (postits (gensym "POSTITS-"))
- (emitter nil)
- (decls nil)
- (attributes nil)
- (cost nil)
- (dependencies nil)
- (delay nil)
- (pinned nil)
- (pdefs nil))
+ (defun-name (sb!int:symbolicate sym-name "-INST-EMITTER"))
+ (vop-var nil)
+ (postits (gensym "POSTITS-"))
+ (emitter nil)
+ (decls nil)
+ (attributes nil)
+ (cost nil)
+ (dependencies nil)
+ (delay nil)
+ (pinned nil)
+ (pdefs nil))
(sb!int:/noshow "entering DEFINE-INSTRUCTION" name lambda-list options)
(dolist (option-spec options)
(sb!int:/noshow option-spec)
(multiple-value-bind (option args)
- (if (consp option-spec)
- (values (car option-spec) (cdr option-spec))
- (values option-spec nil))
- (sb!int:/noshow option args)
- (case option
- (:emitter
- (when emitter
- (error "You can only specify :EMITTER once per instruction."))
- (setf emitter args))
- (:declare
- (setf decls (append decls args)))
- (:attributes
- (setf attributes (append attributes args)))
- (:cost
- (setf cost (first args)))
- (:dependencies
- (setf dependencies (append dependencies args)))
- (:delay
- (when delay
- (error "You can only specify :DELAY once per instruction."))
- (setf delay args))
- (:pinned
- (setf pinned t))
- (:vop-var
- (if vop-var
- (error "You can only specify :VOP-VAR once per instruction.")
- (setf vop-var (car args))))
- (:printer
- (sb!int:/noshow "uniquifying :PRINTER with" args)
- (push (eval `(list (multiple-value-list
- ,(sb!disassem:gen-printer-def-forms-def-form
- name
- (format nil "~@:(~A[~A]~)" name args)
- (cdr option-spec)))))
- pdefs))
- (:printer-list
- ;; same as :PRINTER, but is EVALed first, and is a list of
- ;; printers
- (push
- (eval
- `(eval
- `(list ,@(mapcar (lambda (printer)
- `(multiple-value-list
- ,(sb!disassem:gen-printer-def-forms-def-form
- ',name
- (format nil "~@:(~A[~A]~)" ',name printer)
- printer
- nil)))
- ,(cadr option-spec)))))
- pdefs))
- (t
- (error "unknown option: ~S" option)))))
+ (if (consp option-spec)
+ (values (car option-spec) (cdr option-spec))
+ (values option-spec nil))
+ (sb!int:/noshow option args)
+ (case option
+ (:emitter
+ (when emitter
+ (error "You can only specify :EMITTER once per instruction."))
+ (setf emitter args))
+ (:declare
+ (setf decls (append decls args)))
+ (:attributes
+ (setf attributes (append attributes args)))
+ (:cost
+ (setf cost (first args)))
+ (:dependencies
+ (setf dependencies (append dependencies args)))
+ (:delay
+ (when delay
+ (error "You can only specify :DELAY once per instruction."))
+ (setf delay args))
+ (:pinned
+ (setf pinned t))
+ (:vop-var
+ (if vop-var
+ (error "You can only specify :VOP-VAR once per instruction.")
+ (setf vop-var (car args))))
+ (:printer
+ (sb!int:/noshow "uniquifying :PRINTER with" args)
+ (push (eval `(list (multiple-value-list
+ ,(sb!disassem:gen-printer-def-forms-def-form
+ name
+ (format nil "~@:(~A[~A]~)" name args)
+ (cdr option-spec)))))
+ pdefs))
+ (:printer-list
+ ;; same as :PRINTER, but is EVALed first, and is a list of
+ ;; printers
+ (push
+ (eval
+ `(eval
+ `(list ,@(mapcar (lambda (printer)
+ `(multiple-value-list
+ ,(sb!disassem:gen-printer-def-forms-def-form
+ ',name
+ (format nil "~@:(~A[~A]~)" ',name printer)
+ printer
+ nil)))
+ ,(cadr option-spec)))))
+ pdefs))
+ (t
+ (error "unknown option: ~S" option)))))
(sb!int:/noshow "done processing options")
(setf pdefs (nreverse pdefs))
(multiple-value-bind
- (new-lambda-list segment-name vop-name arg-reconstructor)
- (grovel-lambda-list lambda-list vop-var)
+ (new-lambda-list segment-name vop-name arg-reconstructor)
+ (grovel-lambda-list lambda-list vop-var)
(sb!int:/noshow new-lambda-list segment-name vop-name arg-reconstructor)
(push `(let ((hook (segment-inst-hook ,segment-name)))
- (when hook
- (funcall hook ,segment-name ,vop-name ,sym-name
- ,arg-reconstructor)))
- emitter)
+ (when hook
+ (funcall hook ,segment-name ,vop-name ,sym-name
+ ,arg-reconstructor)))
+ emitter)
(push `(dolist (postit ,postits)
- (emit-back-patch ,segment-name 0 postit))
- emitter)
+ (emit-back-patch ,segment-name 0 postit))
+ emitter)
(unless cost (setf cost 1))
#!+sb-dyncount
(push `(when (segment-collect-dynamic-statistics ,segment-name)
- (let* ((info (sb!c:ir2-component-dyncount-info
- (sb!c:component-info
- sb!c:*component-being-compiled*)))
- (costs (sb!c:dyncount-info-costs info))
- (block-number (sb!c:block-number
- (sb!c:ir2-block-block
- (sb!c:vop-block ,vop-name)))))
- (incf (aref costs block-number) ,cost)))
- emitter)
+ (let* ((info (sb!c:ir2-component-dyncount-info
+ (sb!c:component-info
+ sb!c:*component-being-compiled*)))
+ (costs (sb!c:dyncount-info-costs info))
+ (block-number (sb!c:block-number
+ (sb!c:ir2-block-block
+ (sb!c:vop-block ,vop-name)))))
+ (incf (aref costs block-number) ,cost)))
+ emitter)
(when *assem-scheduler-p*
- (if pinned
- (setf emitter
- `((when (segment-run-scheduler ,segment-name)
- (schedule-pending-instructions ,segment-name))
- ,@emitter))
- (let ((flet-name
- (gensym (concatenate 'string "EMIT-" sym-name "-INST-")))
- (inst-name (gensym "INST-")))
- (setf emitter `((flet ((,flet-name (,segment-name)
- ,@emitter))
- (if (segment-run-scheduler ,segment-name)
- (let ((,inst-name
- (make-instruction
- (incf (segment-inst-number
- ,segment-name))
- #',flet-name
- (instruction-attributes
- ,@attributes)
- (progn ,@delay))))
- ,@(when dependencies
- `((note-dependencies
- (,segment-name ,inst-name)
- ,@dependencies)))
- (queue-inst ,segment-name ,inst-name))
- (,flet-name ,segment-name))))))))
+ (if pinned
+ (setf emitter
+ `((when (segment-run-scheduler ,segment-name)
+ (schedule-pending-instructions ,segment-name))
+ ,@emitter))
+ (let ((flet-name
+ (gensym (concatenate 'string "EMIT-" sym-name "-INST-")))
+ (inst-name (gensym "INST-")))
+ (setf emitter `((flet ((,flet-name (,segment-name)
+ ,@emitter))
+ (if (segment-run-scheduler ,segment-name)
+ (let ((,inst-name
+ (make-instruction
+ (incf (segment-inst-number
+ ,segment-name))
+ #',flet-name
+ (instruction-attributes
+ ,@attributes)
+ (progn ,@delay))))
+ ,@(when dependencies
+ `((note-dependencies
+ (,segment-name ,inst-name)
+ ,@dependencies)))
+ (queue-inst ,segment-name ,inst-name))
+ (,flet-name ,segment-name))))))))
`(progn
- (defun ,defun-name ,new-lambda-list
- ,@(when decls
- `((declare ,@decls)))
- (let ((,postits (segment-postits ,segment-name)))
- ;; Must be done so that contribs and user code doing
- ;; low-level stuff don't need to worry about this.
- (declare (disable-package-locks %%current-segment%%))
- (setf (segment-postits ,segment-name) nil)
- (macrolet ((%%current-segment%% ()
- (error "You can't use INST without an ~
+ (defun ,defun-name ,new-lambda-list
+ ,@(when decls
+ `((declare ,@decls)))
+ (let ((,postits (segment-postits ,segment-name)))
+ ;; Must be done so that contribs and user code doing
+ ;; low-level stuff don't need to worry about this.
+ (declare (disable-package-locks %%current-segment%%))
+ (setf (segment-postits ,segment-name) nil)
+ (macrolet ((%%current-segment%% ()
+ (error "You can't use INST without an ~
ASSEMBLE inside emitters.")))
;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
;; can't deal with this declaration, so disable it on host
;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%%
;; declaration.
#-sb-xc-host
- (declare (enable-package-locks %%current-segment%%))
- ,@emitter))
- (values))
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (%define-instruction ,sym-name ',defun-name))
- ,@(extract-nths 1 'progn pdefs)
- ,@(when pdefs
- `((sb!disassem:install-inst-flavors
- ',name
- (append ,@(extract-nths 0 'list pdefs)))))))))
+ (declare (enable-package-locks %%current-segment%%))
+ ,@emitter))
+ (values))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (%define-instruction ,sym-name ',defun-name))
+ ,@(extract-nths 1 'progn pdefs)
+ ,@(when pdefs
+ `((sb!disassem:install-inst-flavors
+ ',name
+ (append ,@(extract-nths 0 'list pdefs)))))))))
(defmacro define-instruction-macro (name lambda-list &body body)
(with-unique-names (whole env)
(multiple-value-bind (body local-defs)
- (sb!kernel:parse-defmacro lambda-list
- whole
- body
- name
- 'instruction-macro
- :environment env)
+ (sb!kernel:parse-defmacro lambda-list
+ whole
+ body
+ name
+ 'instruction-macro
+ :environment env)
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (%define-instruction ,(symbol-name name)
- (lambda (,whole ,env)
- ,@local-defs
- (block ,name
- ,body)))))))
+ (%define-instruction ,(symbol-name name)
+ (lambda (,whole ,env)
+ ,@local-defs
+ (block ,name
+ ,body)))))))
(defun %define-instruction (name defun)
(setf (gethash name *assem-instructions*) defun)
(defvar *backend-meta-sc-names* (make-hash-table :test 'eq))
(defvar *backend-meta-sb-names* (make-hash-table :test 'eq))
(declaim (type hash-table
- *backend-sc-names*
- *backend-sb-names*
- *backend-meta-sc-names*
- *backend-meta-sb-names*))
+ *backend-sc-names*
+ *backend-sb-names*
+ *backend-meta-sc-names*
+ *backend-meta-sb-names*))
;;; like *SC-NUMBERS*, but updated at meta-compile time
(defvar *backend-instruction-flavors* (make-hash-table :test 'equal))
(defvar *backend-special-arg-types* (make-hash-table :test 'eq))
(declaim (type hash-table
- *backend-instruction-formats*
- *backend-instruction-flavors*
- *backend-special-arg-types*))
+ *backend-instruction-formats*
+ *backend-instruction-flavors*
+ *backend-special-arg-types*))
;;; mappings between CTYPE structures and the corresponding predicate.
;;; The type->predicate mapping is implemented as an alist because
(defvar *backend-support-routines*)
(macrolet ((def-vm-support-routines (&rest routines)
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter *vm-support-routines* ',routines))
- (defstruct (vm-support-routines (:copier nil))
- ,@(mapcar (lambda (routine)
- `(,routine nil :type (or function null)))
- routines))
- ,@(mapcar
- (lambda (name)
- `(defun ,name (&rest args)
- (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-"
- name)
- *backend-support-routines*)
- (error "machine-specific support ~S ~
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *vm-support-routines* ',routines))
+ (defstruct (vm-support-routines (:copier nil))
+ ,@(mapcar (lambda (routine)
+ `(,routine nil :type (or function null)))
+ routines))
+ ,@(mapcar
+ (lambda (name)
+ `(defun ,name (&rest args)
+ (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-"
+ name)
+ *backend-support-routines*)
+ (error "machine-specific support ~S ~
routine undefined"
- ',name))
- args)))
- routines))))
+ ',name))
+ args)))
+ routines))))
(def-vm-support-routines
(defmacro !def-vm-support-routine (name ll &body body)
(unless (member (intern (string name) (find-package "SB!C"))
- *vm-support-routines*)
+ *vm-support-routines*)
(warn "unknown VM support routine: ~A" name))
(let ((local-name (symbolicate "IMPL-OF-VM-SUPPORT-ROUTINE-" name)))
`(progn
(defun ,local-name ,ll ,@body)
(setf (,(intern (concatenate 'simple-string
- "VM-SUPPORT-ROUTINES-"
- (string name))
- (find-package "SB!C"))
- *backend-support-routines*)
- #',local-name))))
+ "VM-SUPPORT-ROUTINES-"
+ (string name))
+ (find-package "SB!C"))
+ *backend-support-routines*)
+ #',local-name))))
;;; the VM support routines
(defvar *backend-support-routines* (make-vm-support-routines))
(NOT (BACKEND-FEATUREP :SPARC-64)))))
...)
-and at the IR2 translation stage, the function #'`(LAMBDA () ,GUARD) would be called.
+and at the IR2 translation stage, the function #'`(LAMBDA () ,GUARD) would be called.
-Until SBCL-0.7pre57, this is translated as
+Until SBCL-0.7pre57, this is translated as
(:GUARD #!+(OR :SPARC-V8 (AND :SPARC-V9 (NOT :SPARC-64))) T
#!-(OR :SPARC-V8 (AND :SPARC-V9 (NOT :SPARC-64))) NIL)
which means that whether this VOP will ever be used is determined at
#!-sb-fluid
(declaim (inline clear-bit-vector set-bit-vector bit-vector-replace
- bit-vector-copy))
+ bit-vector-copy))
;;; Clear a SIMPLE-BIT-VECTOR to zeros.
(defun clear-bit-vector (vec)
;;; less-portable implementation of CLEAR-BIT-VECTOR:
;;; (do ((i sb!vm:vector-data-offset (1+ i))
;;; (end (+ sb!vm:vector-data-offset
-;;; (ash (+ (length vec) (1- sb!vm:n-word-bits))
-;;; (- (1- (integer-length sb!vm:n-word-bits)))))))
+;;; (ash (+ (length vec) (1- sb!vm:n-word-bits))
+;;; (- (1- (integer-length sb!vm:n-word-bits)))))))
;;; ((= i end) vec)
;;; (setf (sb!kernel:%raw-bits vec i) 0)))
;;; We could use this in the target SBCL if the new version turns out to be a
(defun fun-guessed-cost (name)
(declare (symbol name))
(let ((info (info :function :info name))
- (call-cost (template-cost (template-or-lose 'call-named))))
+ (call-cost (template-cost (template-or-lose 'call-named))))
(if info
- (let ((templates (fun-info-templates info)))
- (if templates
- (template-cost (first templates))
- (case name
- (null (template-cost (template-or-lose 'if-eq)))
- (t call-cost))))
- call-cost)))
+ (let ((templates (fun-info-templates info)))
+ (if templates
+ (template-cost (first templates))
+ (case name
+ (null (template-cost (template-or-lose 'if-eq)))
+ (t call-cost))))
+ call-cost)))
;;; Return some sort of guess for the cost of doing a test against
;;; TYPE. The result need not be precise as long as it isn't way out
(when (eq type *empty-type*)
0)
(let ((check (type-check-template type)))
- (if check
- (template-cost check)
- (let ((found (cdr (assoc type *backend-type-predicates*
- :test #'type=))))
- (if found
- (+ (fun-guessed-cost found) (fun-guessed-cost 'eq))
- nil))))
+ (if check
+ (template-cost check)
+ (let ((found (cdr (assoc type *backend-type-predicates*
+ :test #'type=))))
+ (if found
+ (+ (fun-guessed-cost found) (fun-guessed-cost 'eq))
+ nil))))
(typecase type
- (compound-type
- (reduce #'+ (compound-type-types type) :key 'type-test-cost))
- (member-type
- (* (length (member-type-members type))
- (fun-guessed-cost 'eq)))
- (numeric-type
- (* (if (numeric-type-complexp type) 2 1)
- (fun-guessed-cost
- (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp))
- (+ 1
- (if (numeric-type-low type) 1 0)
- (if (numeric-type-high type) 1 0))))
- (cons-type
- (+ (type-test-cost (specifier-type 'cons))
- (fun-guessed-cost 'car)
- (type-test-cost (cons-type-car-type type))
- (fun-guessed-cost 'cdr)
- (type-test-cost (cons-type-cdr-type type))))
- (t
- (fun-guessed-cost 'typep)))))
+ (compound-type
+ (reduce #'+ (compound-type-types type) :key 'type-test-cost))
+ (member-type
+ (* (length (member-type-members type))
+ (fun-guessed-cost 'eq)))
+ (numeric-type
+ (* (if (numeric-type-complexp type) 2 1)
+ (fun-guessed-cost
+ (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp))
+ (+ 1
+ (if (numeric-type-low type) 1 0)
+ (if (numeric-type-high type) 1 0))))
+ (cons-type
+ (+ (type-test-cost (specifier-type 'cons))
+ (fun-guessed-cost 'car)
+ (type-test-cost (cons-type-car-type type))
+ (fun-guessed-cost 'cdr)
+ (type-test-cost (cons-type-cdr-type type))))
+ (t
+ (fun-guessed-cost 'typep)))))
(defun-cached
(weaken-type :hash-bits 8
(declare (type ctype type))
(multiple-value-bind (res count) (values-types type)
(values (mapcar (lambda (type)
- (if (fun-type-p type)
- (specifier-type 'function)
- type))
- res)
- count)))
+ (if (fun-type-p type)
+ (specifier-type 'function)
+ type))
+ res)
+ count)))
;;; Switch to disable check complementing, for evaluation.
(defvar *complement-type-checks* t)
;;; Determines whether CAST's assertion is:
;;; -- checkable by the back end (:SIMPLE), or
-;;; -- not checkable by the back end, but checkable via an explicit
+;;; -- not checkable by the back end, but checkable via an explicit
;;; test in type check conversion (:HAIRY), or
;;; -- not reasonably checkable at all (:TOO-HAIRY).
;;;
(t t))
#+nil
(cond ((or (not dest)
- (policy dest (zerop safety)))
- nil)
- ((basic-combination-p dest)
- (let ((kind (basic-combination-kind dest)))
- (cond
- ((eq cont (basic-combination-fun dest)) t)
- (t
- (ecase kind
- (:local t)
- (:full
- (and (combination-p dest)
- (not (values-subtypep ; explicit THE
- (continuation-externally-checkable-type cont)
- (continuation-type-to-check cont)))))
- ;; :ERROR means that we have an invalid syntax of
- ;; the call and the callee will detect it before
- ;; thinking about types.
- (:error nil)
- (:known
- (let ((info (basic-combination-fun-info dest)))
- (if (fun-info-ir2-convert info)
- t
- (dolist (template (fun-info-templates info) nil)
- (when (eq (template-ltn-policy template)
- :fast-safe)
- (multiple-value-bind (val win)
- (valid-fun-use dest (template-type template))
- (when (or val (not win)) (return t)))))))))))))
- (t t))))
+ (policy dest (zerop safety)))
+ nil)
+ ((basic-combination-p dest)
+ (let ((kind (basic-combination-kind dest)))
+ (cond
+ ((eq cont (basic-combination-fun dest)) t)
+ (t
+ (ecase kind
+ (:local t)
+ (:full
+ (and (combination-p dest)
+ (not (values-subtypep ; explicit THE
+ (continuation-externally-checkable-type cont)
+ (continuation-type-to-check cont)))))
+ ;; :ERROR means that we have an invalid syntax of
+ ;; the call and the callee will detect it before
+ ;; thinking about types.
+ (:error nil)
+ (:known
+ (let ((info (basic-combination-fun-info dest)))
+ (if (fun-info-ir2-convert info)
+ t
+ (dolist (template (fun-info-templates info) nil)
+ (when (eq (template-ltn-policy template)
+ :fast-safe)
+ (multiple-value-bind (val win)
+ (valid-fun-use dest (template-type template))
+ (when (or val (not win)) (return t)))))))))))))
+ (t t))))
;;; Return a lambda form that we can convert to do a hairy type check
;;; of the specified TYPES. TYPES is a list of the format returned by
(setf (cast-%type-check cast) nil)
(let* ((atype (cast-asserted-type cast))
(atype (cond ((not (values-type-p atype))
- atype)
- ((= length 1)
+ atype)
+ ((= length 1)
(single-value-type atype))
(t
- (make-values-type
+ (make-values-type
:required (values-type-out atype length)))))
(dtype (node-derived-type cast))
(dtype (make-values-type
pos)))))))
(cond ((and (ref-p use) (constant-p (ref-leaf use)))
(warn 'type-warning
- :format-control
- "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
- :format-arguments
- (list what atype-spec
- (constant-value (ref-leaf use)))))
+ :format-control
+ "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
+ :format-arguments
+ (list what atype-spec
+ (constant-value (ref-leaf use)))))
(t
(warn 'type-warning
- :format-control
- "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
- :format-arguments
- (list what (type-specifier dtype) atype-spec)))))))))
+ :format-control
+ "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
+ :format-arguments
+ (list what (type-specifier dtype) atype-spec)))))))))
(values))
;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set,
(do-blocks (block component)
(when (block-type-check block)
;; CAST-EXTERNALLY-CHECKABLE-P wants the backward pass
- (do-nodes-backwards (node nil block)
+ (do-nodes-backwards (node nil block)
(when (and (cast-p node)
(cast-type-check node))
(cast-check-uses node)
;; the previous pass
(setf (cast-%type-check node) t)
(casts (cons node (not (probable-type-check-p node))))))))
- (setf (block-type-check block) nil)))
+ (setf (block-type-check block) nil)))
(dolist (cast (casts))
(destructuring-bind (cast . force-hairy) cast
(multiple-value-bind (check types)
;;; the number of bytes used by the code object header
(defun component-header-length (&optional
- (component *component-being-compiled*))
+ (component *component-being-compiled*))
(let* ((2comp (component-info component))
- (constants (ir2-component-constants 2comp))
- (num-consts (length constants)))
+ (constants (ir2-component-constants 2comp))
+ (num-consts (length constants)))
(ash (logandc2 (1+ num-consts) 1) sb!vm:word-shift)))
;;; the size of the NAME'd SB in the currently compiled component.
(unless (zerop (sb-allocated-size 'non-descriptor-stack))
(let ((block (ir2-block-block (vop-block vop))))
(when (ir2-physenv-number-stack-p
- (physenv-info
- (block-physenv block)))
+ (physenv-info
+ (block-physenv block)))
(ir2-component-nfp (component-info (block-component block)))))))
;;; the TN that is used to hold the number stack frame-pointer in the
(setf *prev-segment* segment))
(unless (eq *prev-vop* vop)
(when vop
- (format t "~%VOP ")
- (if (vop-p vop)
- (print-vop vop)
- (format *compiler-trace-output* "~S~%" vop)))
+ (format t "~%VOP ")
+ (if (vop-p vop)
+ (print-vop vop)
+ (format *compiler-trace-output* "~S~%" vop)))
(terpri)
(setf *prev-vop* vop))
(case inst
;;; standard defaults for slots of SEGMENT objects
(defun default-segment-run-scheduler ()
(and *assembly-optimize*
- (policy (lambda-bind
- (block-home-lambda
- (block-next (component-head *component-being-compiled*))))
- (or (> speed compilation-speed) (> space compilation-speed)))))
+ (policy (lambda-bind
+ (block-home-lambda
+ (block-next (component-head *component-being-compiled*))))
+ (or (> speed compilation-speed) (> space compilation-speed)))))
(defun default-segment-inst-hook ()
(and *compiler-trace-output*
#'trace-instruction))
(defun init-assembler ()
(setf *code-segment*
- (sb!assem:make-segment :name "regular"
- :run-scheduler (default-segment-run-scheduler)
- :inst-hook (default-segment-inst-hook)))
+ (sb!assem:make-segment :name "regular"
+ :run-scheduler (default-segment-run-scheduler)
+ :inst-hook (default-segment-inst-hook)))
#!+sb-dyncount
(setf (sb!assem:segment-collect-dynamic-statistics *code-segment*)
- *collect-dynamic-statistics*)
+ *collect-dynamic-statistics*)
(setf *elsewhere*
- (sb!assem:make-segment :name "elsewhere"
- :run-scheduler (default-segment-run-scheduler)
- :inst-hook (default-segment-inst-hook)))
+ (sb!assem:make-segment :name "elsewhere"
+ :run-scheduler (default-segment-run-scheduler)
+ :inst-hook (default-segment-inst-hook)))
(values))
(defun generate-code (component)
(when *compiler-trace-output*
(format *compiler-trace-output*
- "~|~%assembly code for ~S~2%"
- component))
+ "~|~%assembly code for ~S~2%"
+ component))
(let ((prev-env nil)
- (*trace-table-info* nil)
- (*prev-segment* nil)
- (*prev-vop* nil)
- (*fixup-notes* nil))
+ (*trace-table-info* nil)
+ (*prev-segment* nil)
+ (*prev-vop* nil)
+ (*fixup-notes* nil))
(let ((label (sb!assem:gen-label)))
(setf *elsewhere-label* label)
(sb!assem:assemble (*elsewhere*)
- (sb!assem:emit-label label)))
+ (sb!assem:emit-label label)))
(do-ir2-blocks (block component)
(let ((1block (ir2-block-block block)))
- (when (and (eq (block-info 1block) block)
- (block-start 1block))
- (sb!assem:assemble (*code-segment*)
- (sb!assem:emit-label (block-label 1block)))
- (let ((env (block-physenv 1block)))
- (unless (eq env prev-env)
- (let ((lab (gen-label)))
- (setf (ir2-physenv-elsewhere-start (physenv-info env))
- lab)
- (emit-label-elsewhere lab))
- (setq prev-env env)))))
+ (when (and (eq (block-info 1block) block)
+ (block-start 1block))
+ (sb!assem:assemble (*code-segment*)
+ (sb!assem:emit-label (block-label 1block)))
+ (let ((env (block-physenv 1block)))
+ (unless (eq env prev-env)
+ (let ((lab (gen-label)))
+ (setf (ir2-physenv-elsewhere-start (physenv-info env))
+ lab)
+ (emit-label-elsewhere lab))
+ (setq prev-env env)))))
(do ((vop (ir2-block-start-vop block) (vop-next vop)))
- ((null vop))
- (let ((gen (vop-info-generator-function (vop-info vop))))
- (if gen
- (funcall gen vop)
- (format t
- "missing generator for ~S~%"
- (template-name (vop-info vop)))))))
+ ((null vop))
+ (let ((gen (vop-info-generator-function (vop-info vop))))
+ (if gen
+ (funcall gen vop)
+ (format t
+ "missing generator for ~S~%"
+ (template-name (vop-info vop)))))))
(sb!assem:append-segment *code-segment* *elsewhere*)
(setf *elsewhere* nil)
(values (sb!assem:finalize-segment *code-segment*)
- (nreverse *trace-table-info*)
- *fixup-notes*)))
+ (nreverse *trace-table-info*)
+ *fixup-notes*)))
(defun emit-label-elsewhere (label)
(sb!assem:assemble (*elsewhere*)
(defun label-elsewhere-p (label-or-posn)
(<= (label-position *elsewhere-label*)
(etypecase label-or-posn
- (label
- (label-position label-or-posn))
- (index
- label-or-posn))))
+ (label
+ (label-position label-or-posn))
+ (index
+ label-or-posn))))
;;; CSR, 2003-05-13
(define-condition compiler-error (encapsulated-condition) ()
(:report (lambda (condition stream)
- (print-object (encapsulated-condition condition) stream))))
+ (print-object (encapsulated-condition condition) stream))))
;;; Signal the appropriate condition. COMPILER-ERROR calls the bailout
;;; function so that it never returns (but compilation continues).
(;; the position where the bad READ began, or NIL if unavailable,
;; redundant, or irrelevant
(position :reader input-error-in-compile-file-position
- :initarg :position
- :initform nil))
+ :initarg :position
+ :initform nil))
(:report
(lambda (condition stream)
(format stream
- "~@<~S failure in ~S~@[ at character ~W~]: ~2I~_~A~:>"
- 'read
- 'compile-file
- (input-error-in-compile-file-position condition)
- (encapsulated-condition condition)))))
+ "~@<~S failure in ~S~@[ at character ~W~]: ~2I~_~A~:>"
+ 'read
+ 'compile-file
+ (input-error-in-compile-file-position condition)
+ (encapsulated-condition condition)))))
(in-package "SB!C")
(defstruct (constraint
- (:include sset-element)
- (:constructor make-constraint (number kind x y not-p))
- (:copier nil))
+ (:include sset-element)
+ (:constructor make-constraint (number kind x y not-p))
+ (:copier nil))
;; the kind of constraint we have:
;;
;; TYPEP
;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
(defun find-constraint (kind x y not-p)
(declare (type lambda-var x) (type (or constant lambda-var ctype) y)
- (type boolean not-p))
+ (type boolean not-p))
(or (etypecase y
- (ctype
- (do-sset-elements (con (lambda-var-constraints x) nil)
- (when (and (eq (constraint-kind con) kind)
- (eq (constraint-not-p con) not-p)
- (type= (constraint-y con) y))
- (return con))))
- (constant
- (do-sset-elements (con (lambda-var-constraints x) nil)
- (when (and (eq (constraint-kind con) kind)
- (eq (constraint-not-p con) not-p)
- (eq (constraint-y con) y))
- (return con))))
- (lambda-var
- (do-sset-elements (con (lambda-var-constraints x) nil)
- (when (and (eq (constraint-kind con) kind)
- (eq (constraint-not-p con) not-p)
- (let ((cx (constraint-x con)))
- (eq (if (eq cx x)
- (constraint-y con)
- cx)
- y)))
- (return con)))))
+ (ctype
+ (do-sset-elements (con (lambda-var-constraints x) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (type= (constraint-y con) y))
+ (return con))))
+ (constant
+ (do-sset-elements (con (lambda-var-constraints x) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (eq (constraint-y con) y))
+ (return con))))
+ (lambda-var
+ (do-sset-elements (con (lambda-var-constraints x) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (let ((cx (constraint-x con)))
+ (eq (if (eq cx x)
+ (constraint-y con)
+ cx)
+ y)))
+ (return con)))))
(let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
- (sset-adjoin new (lambda-var-constraints x))
- (when (lambda-var-p y)
- (sset-adjoin new (lambda-var-constraints y)))
- new)))
+ (sset-adjoin new (lambda-var-constraints x))
+ (when (lambda-var-p y)
+ (sset-adjoin new (lambda-var-constraints y)))
+ new)))
;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
(declare (type ref ref))
(let ((leaf (ref-leaf ref)))
(when (and (lambda-var-p leaf)
- (lambda-var-constraints leaf))
+ (lambda-var-constraints leaf))
leaf)))
;;; If LVAR's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
(defun add-test-constraint (block fun x y not-p)
(unless (rest (block-pred block))
(let ((con (find-constraint fun x y not-p))
- (old (or (block-test-constraint block)
- (setf (block-test-constraint block) (make-sset)))))
+ (old (or (block-test-constraint block)
+ (setf (block-test-constraint block) (make-sset)))))
(when (sset-adjoin con old)
- (setf (block-type-asserted block) t))))
+ (setf (block-type-asserted block) t))))
(values))
;;; Add complementary constraints to the consequent and alternative
;;; blocks of IF. We do nothing if X is NIL.
(defun add-complement-constraints (if fun x y not-p)
(when (and x
- ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
- ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means
- ;; that we can't guarantee that the optimization will be
- ;; done, so we still need to avoid barfing on this case.
+ ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
+ ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means
+ ;; that we can't guarantee that the optimization will be
+ ;; done, so we still need to avoid barfing on this case.
(not (eq (if-consequent if)
(if-alternative if))))
(add-test-constraint (if-consequent if) fun x y not-p)
(typecase use
(ref
(add-complement-constraints if 'typep (ok-ref-lambda-var use)
- (specifier-type 'null) t))
+ (specifier-type 'null) t))
(combination
(unless (eq (combination-kind use)
:error)
(let ((last (block-last block)))
(when (if-p last)
(let ((use (lvar-uses (if-test last))))
- (when (node-p use)
- (add-test-constraints use last)))))
+ (when (node-p use)
+ (add-test-constraints use last)))))
(setf (block-test-modified block) nil)
(values))
(defun constrain-integer-type (x y greater or-equal)
(declare (type numeric-type x y))
(flet ((exclude (x)
- (cond ((not x) nil)
- (or-equal x)
- (greater (1+ x))
- (t (1- x))))
- (bound (x)
- (if greater (numeric-type-low x) (numeric-type-high x))))
+ (cond ((not x) nil)
+ (or-equal x)
+ (greater (1+ x))
+ (t (1- x))))
+ (bound (x)
+ (if greater (numeric-type-low x) (numeric-type-high x))))
(let* ((x-bound (bound x))
- (y-bound (exclude (bound y)))
- (new-bound (cond ((not x-bound) y-bound)
- ((not y-bound) x-bound)
- (greater (max x-bound y-bound))
- (t (min x-bound y-bound)))))
+ (y-bound (exclude (bound y)))
+ (new-bound (cond ((not x-bound) y-bound)
+ ((not y-bound) x-bound)
+ (greater (max x-bound y-bound))
+ (t (min x-bound y-bound)))))
(if greater
- (modified-numeric-type x :low new-bound)
- (modified-numeric-type x :high new-bound)))))
+ (modified-numeric-type x :low new-bound)
+ (modified-numeric-type x :high new-bound)))))
;;; Return true if X is a float NUMERIC-TYPE.
(defun float-type-p (x)
x
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(labels ((exclude (x)
- (cond ((not x) nil)
- (or-equal x)
- (greater
- (if (consp x)
- (car x)
- x))
- (t
- (if (consp x)
- x
- (list x)))))
- (bound (x)
- (if greater (numeric-type-low x) (numeric-type-high x)))
- (max-lower-bound (x y)
- ;; Both X and Y are not null. Find the max.
- (let ((res (max (type-bound-number x) (type-bound-number y))))
- ;; An open lower bound is greater than a close
- ;; lower bound because the open bound doesn't
- ;; contain the bound, so choose an open lower
- ;; bound.
- (set-bound res (or (consp x) (consp y)))))
- (min-upper-bound (x y)
- ;; Same as above, but for the min of upper bounds
- ;; Both X and Y are not null. Find the min.
- (let ((res (min (type-bound-number x) (type-bound-number y))))
- ;; An open upper bound is less than a closed
- ;; upper bound because the open bound doesn't
- ;; contain the bound, so choose an open lower
- ;; bound.
- (set-bound res (or (consp x) (consp y))))))
+ (cond ((not x) nil)
+ (or-equal x)
+ (greater
+ (if (consp x)
+ (car x)
+ x))
+ (t
+ (if (consp x)
+ x
+ (list x)))))
+ (bound (x)
+ (if greater (numeric-type-low x) (numeric-type-high x)))
+ (max-lower-bound (x y)
+ ;; Both X and Y are not null. Find the max.
+ (let ((res (max (type-bound-number x) (type-bound-number y))))
+ ;; An open lower bound is greater than a close
+ ;; lower bound because the open bound doesn't
+ ;; contain the bound, so choose an open lower
+ ;; bound.
+ (set-bound res (or (consp x) (consp y)))))
+ (min-upper-bound (x y)
+ ;; Same as above, but for the min of upper bounds
+ ;; Both X and Y are not null. Find the min.
+ (let ((res (min (type-bound-number x) (type-bound-number y))))
+ ;; An open upper bound is less than a closed
+ ;; upper bound because the open bound doesn't
+ ;; contain the bound, so choose an open lower
+ ;; bound.
+ (set-bound res (or (consp x) (consp y))))))
(let* ((x-bound (bound x))
- (y-bound (exclude (bound y)))
- (new-bound (cond ((not x-bound)
- y-bound)
- ((not y-bound)
- x-bound)
- (greater
- (max-lower-bound x-bound y-bound))
- (t
- (min-upper-bound x-bound y-bound)))))
+ (y-bound (exclude (bound y)))
+ (new-bound (cond ((not x-bound)
+ y-bound)
+ ((not y-bound)
+ x-bound)
+ (greater
+ (max-lower-bound x-bound y-bound))
+ (t
+ (min-upper-bound x-bound y-bound)))))
(if greater
- (modified-numeric-type x :low new-bound)
- (modified-numeric-type x :high new-bound)))))
+ (modified-numeric-type x :low new-bound)
+ (modified-numeric-type x :high new-bound)))))
;;; Given the set of CONSTRAINTS for a variable and the current set of
;;; restrictions from flow analysis IN, set the type for REF
(let ((var-cons (copy-sset constraints)))
(sset-intersection var-cons in)
(let ((res (single-value-type (node-derived-type ref)))
- (not-res *empty-type*)
- (leaf (ref-leaf ref)))
+ (not-res *empty-type*)
+ (leaf (ref-leaf ref)))
(do-sset-elements (con var-cons)
- (let* ((x (constraint-x con))
- (y (constraint-y con))
- (not-p (constraint-not-p con))
- (other (if (eq x leaf) y x))
- (kind (constraint-kind con)))
- (case kind
- (typep
- (if not-p
- (setq not-res (type-union not-res other))
- (setq res (type-approx-intersection2 res other))))
- (eql
- (let ((other-type (leaf-type other)))
- (if not-p
- (when (and (constant-p other)
- (member-type-p other-type))
- (setq not-res (type-union not-res other-type)))
- (let ((leaf-type (leaf-type leaf)))
- (when (or (constant-p other)
- (and (leaf-refs other) ; protect from deleted vars
+ (let* ((x (constraint-x con))
+ (y (constraint-y con))
+ (not-p (constraint-not-p con))
+ (other (if (eq x leaf) y x))
+ (kind (constraint-kind con)))
+ (case kind
+ (typep
+ (if not-p
+ (setq not-res (type-union not-res other))
+ (setq res (type-approx-intersection2 res other))))
+ (eql
+ (let ((other-type (leaf-type other)))
+ (if not-p
+ (when (and (constant-p other)
+ (member-type-p other-type))
+ (setq not-res (type-union not-res other-type)))
+ (let ((leaf-type (leaf-type leaf)))
+ (when (or (constant-p other)
+ (and (leaf-refs other) ; protect from deleted vars
(csubtypep other-type leaf-type)
- (not (type= other-type leaf-type))))
- (change-ref-leaf ref other)
- (when (constant-p other) (return)))))))
- ((< >)
- (cond ((and (integer-type-p res) (integer-type-p y))
- (let ((greater (eq kind '>)))
- (let ((greater (if not-p (not greater) greater)))
- (setq res
- (constrain-integer-type res y greater not-p)))))
- ((and (float-type-p res) (float-type-p y))
- (let ((greater (eq kind '>)))
- (let ((greater (if not-p (not greater) greater)))
- (setq res
- (constrain-float-type res y greater not-p)))))
- )))))
+ (not (type= other-type leaf-type))))
+ (change-ref-leaf ref other)
+ (when (constant-p other) (return)))))))
+ ((< >)
+ (cond ((and (integer-type-p res) (integer-type-p y))
+ (let ((greater (eq kind '>)))
+ (let ((greater (if not-p (not greater) greater)))
+ (setq res
+ (constrain-integer-type res y greater not-p)))))
+ ((and (float-type-p res) (float-type-p y))
+ (let ((greater (eq kind '>)))
+ (let ((greater (if not-p (not greater) greater)))
+ (setq res
+ (constrain-float-type res y greater not-p)))))
+ )))))
(cond ((and (if-p (node-dest ref))
(csubtypep (specifier-type 'null) not-res))
(kill (block-kill block))
(out (copy-sset (block-gen block))))
(cond ((null kill)
- (sset-union out in))
- ((null (rest kill))
- (let ((con (lambda-var-constraints (first kill))))
- (if con
- (sset-union-of-difference out in con)
- (sset-union out in))))
- (t
- (let ((kill-set (make-sset)))
- (dolist (var kill)
- (let ((con (lambda-var-constraints var)))
- (when con
- (sset-union kill-set con))))
- (sset-union-of-difference out in kill-set))))
+ (sset-union out in))
+ ((null (rest kill))
+ (let ((con (lambda-var-constraints (first kill))))
+ (if con
+ (sset-union-of-difference out in con)
+ (sset-union out in))))
+ (t
+ (let ((kill-set (make-sset)))
+ (dolist (var kill)
+ (let ((con (lambda-var-constraints var)))
+ (when con
+ (sset-union kill-set con))))
+ (sset-union-of-difference out in kill-set))))
out))
;;; Compute the initial flow analysis sets for BLOCK:
;;; Return True if we have done something.
(defun flow-propagate-constraints (block)
(let* ((pred (block-pred block))
- (in (progn (aver pred)
+ (in (progn (aver pred)
(let ((res (copy-sset (block-out (first pred)))))
(dolist (b (rest pred))
(sset-intersection res (block-out b)))
(declare (type component component))
(dolist (fun (component-lambdas component))
(flet ((frob (x)
- (dolist (var (lambda-vars x))
- (unless (lambda-var-constraints var)
- (when (or (null (lambda-var-sets var))
- (not (closure-var-p var)))
- (setf (lambda-var-constraints var) (make-sset)))))))
+ (dolist (var (lambda-vars x))
+ (unless (lambda-var-constraints var)
+ (when (or (null (lambda-var-sets var))
+ (not (closure-var-p var)))
+ (setf (lambda-var-constraints var) (make-sset)))))))
(frob fun)
(dolist (let (lambda-lets fun))
- (frob let)))))
+ (frob let)))))
;;; How many blocks does COMPONENT have?
(defun component-n-blocks (component)
(defun find-rotated-loop-head (block)
(declare (type cblock block))
(let* ((num (block-number block))
- (env (block-physenv block))
- (pred (dolist (pred (block-pred block) nil)
- (when (and (not (block-flag pred))
- (eq (block-physenv pred) env)
- (< (block-number pred) num))
- (return pred)))))
+ (env (block-physenv block))
+ (pred (dolist (pred (block-pred block) nil)
+ (when (and (not (block-flag pred))
+ (eq (block-physenv pred) env)
+ (< (block-number pred) num))
+ (return pred)))))
(cond
((and pred
- (not (physenv-nlx-info env))
- (not (eq (lambda-block (block-home-lambda block)) block)))
+ (not (physenv-nlx-info env))
+ (not (eq (lambda-block (block-home-lambda block)) block)))
(let ((current pred)
- (current-num (block-number pred)))
- (block DONE
- (loop
- (dolist (pred (block-pred current) (return-from DONE))
- (when (eq pred block)
- (return-from DONE))
- (when (and (not (block-flag pred))
- (eq (block-physenv pred) env)
- (> (block-number pred) current-num))
- (setq current pred current-num (block-number pred))
- (return)))))
- (aver (not (block-flag current)))
- current))
+ (current-num (block-number pred)))
+ (block DONE
+ (loop
+ (dolist (pred (block-pred current) (return-from DONE))
+ (when (eq pred block)
+ (return-from DONE))
+ (when (and (not (block-flag pred))
+ (eq (block-physenv pred) env)
+ (> (block-number pred) current-num))
+ (setq current pred current-num (block-number pred))
+ (return)))))
+ (aver (not (block-flag current)))
+ current))
(t
block))))
(setf (block-flag block) t)
(aver (and (block-component block) (not (block-delete-p block))))
(add-to-emit-order (or (block-info block)
- (setf (block-info block)
- (funcall block-info-constructor block)))
- (block-annotation-prev tail))
+ (setf (block-info block)
+ (funcall block-info-constructor block)))
+ (block-annotation-prev tail))
(let ((last (block-last block)))
- (cond ((and (combination-p last) (node-tail-p last)
- (eq (basic-combination-kind last) :local)
- (not (eq (node-physenv last)
- (lambda-physenv (combination-lambda last)))))
- (combination-lambda last))
- (t
- (let ((component-tail (component-tail (block-component block)))
- (block-succ (block-succ block))
- (fun nil))
- (dolist (succ block-succ)
- (unless (eq (first (block-succ succ)) component-tail)
- (let ((res (control-analyze-block
- succ tail block-info-constructor)))
- (when res (setq fun res)))))
- (dolist (succ block-succ)
- (control-analyze-block succ tail block-info-constructor))
- fun)))))))
+ (cond ((and (combination-p last) (node-tail-p last)
+ (eq (basic-combination-kind last) :local)
+ (not (eq (node-physenv last)
+ (lambda-physenv (combination-lambda last)))))
+ (combination-lambda last))
+ (t
+ (let ((component-tail (component-tail (block-component block)))
+ (block-succ (block-succ block))
+ (fun nil))
+ (dolist (succ block-succ)
+ (unless (eq (first (block-succ succ)) component-tail)
+ (let ((res (control-analyze-block
+ succ tail block-info-constructor)))
+ (when res (setq fun res)))))
+ (dolist (succ block-succ)
+ (control-analyze-block succ tail block-info-constructor))
+ fun)))))))
;;; Analyze all of the NLX EPs first to ensure that code reachable
;;; only from a NLX is emitted contiguously with the code reachable
(type component component)
(type function block-info-constructor))
(let* ((tail-block (block-info (component-tail component)))
- (prev-block (block-annotation-prev tail-block))
- (bind-block (node-block (lambda-bind fun))))
+ (prev-block (block-annotation-prev tail-block))
+ (bind-block (node-block (lambda-bind fun))))
(unless (block-flag bind-block)
(dolist (nlx (physenv-nlx-info (lambda-physenv fun)))
- (control-analyze-block (nlx-info-target nlx) tail-block
- block-info-constructor))
+ (control-analyze-block (nlx-info-target nlx) tail-block
+ block-info-constructor))
(cond
((block-flag bind-block)
- (let* ((block-note (block-info bind-block))
- (prev (block-annotation-prev block-note))
- (next (block-annotation-next block-note)))
- (setf (block-annotation-prev next) prev)
- (setf (block-annotation-next prev) next)
- (add-to-emit-order block-note prev-block)))
+ (let* ((block-note (block-info bind-block))
+ (prev (block-annotation-prev block-note))
+ (next (block-annotation-next block-note)))
+ (setf (block-annotation-prev next) prev)
+ (setf (block-annotation-next prev) next)
+ (add-to-emit-order block-note prev-block)))
(t
- (let ((new-fun (control-analyze-block bind-block
- (block-annotation-next
- prev-block)
- block-info-constructor)))
- (when new-fun
- (control-analyze-1-fun new-fun component
- block-info-constructor)))))))
+ (let ((new-fun (control-analyze-block bind-block
+ (block-annotation-next
+ prev-block)
+ block-info-constructor)))
+ (when new-fun
+ (control-analyze-1-fun new-fun component
+ block-info-constructor)))))))
(values))
;;; Do control analysis on COMPONENT, finding the emit order. Our only
(defevent control-deleted-block "control analysis deleted dead block")
(defun control-analyze (component block-info-constructor)
(declare (type component component)
- (type function block-info-constructor))
+ (type function block-info-constructor))
(let* ((head (component-head component))
- (head-block (funcall block-info-constructor head))
- (tail (component-tail component))
- (tail-block (funcall block-info-constructor tail)))
+ (head-block (funcall block-info-constructor head))
+ (tail (component-tail component))
+ (tail-block (funcall block-info-constructor tail)))
(setf (block-info head) head-block)
(setf (block-info tail) tail-block)
(setf (block-annotation-prev tail-block) head-block)
(dolist (fun (component-lambdas component))
(when (xep-p fun)
- (control-analyze-1-fun fun component block-info-constructor)))
+ (control-analyze-1-fun fun component block-info-constructor)))
(dolist (fun (component-lambdas component))
(control-analyze-1-fun fun component block-info-constructor))
(do-blocks (block component)
(unless (block-flag block)
- (event control-deleted-block (block-start-node block))
- (delete-block block))))
+ (event control-deleted-block (block-start-node block))
+ (delete-block block))))
(let ((2comp (component-info component)))
(when (ir2-component-p 2comp)
;; If it's not an IR2-COMPONENT, don't worry about it.
(setf (ir2-component-values-receivers 2comp)
- (delete-if-not #'block-component
- (ir2-component-values-receivers 2comp)))))
+ (delete-if-not #'block-component
+ (ir2-component-values-receivers 2comp)))))
(values))
(declare (inline subsetp))
(let ((writes (tn-writes tn)))
(and (eq (tn-kind tn) :normal)
- (not (tn-sc tn)) ; Not wired or restricted.
- (and writes (null (tn-ref-next writes)))
- (let ((vop (tn-ref-vop writes)))
- (and (eq (vop-info-name (vop-info vop)) 'move)
- (let ((arg-tn (tn-ref-tn (vop-args vop))))
- (and (or (not (tn-sc arg-tn))
- (eq (tn-kind arg-tn) :constant))
- (subsetp (primitive-type-scs
- (tn-primitive-type tn))
- (primitive-type-scs
- (tn-primitive-type arg-tn)))
- (let ((leaf (tn-leaf tn)))
- (or (not leaf)
+ (not (tn-sc tn)) ; Not wired or restricted.
+ (and writes (null (tn-ref-next writes)))
+ (let ((vop (tn-ref-vop writes)))
+ (and (eq (vop-info-name (vop-info vop)) 'move)
+ (let ((arg-tn (tn-ref-tn (vop-args vop))))
+ (and (or (not (tn-sc arg-tn))
+ (eq (tn-kind arg-tn) :constant))
+ (subsetp (primitive-type-scs
+ (tn-primitive-type tn))
+ (primitive-type-scs
+ (tn-primitive-type arg-tn)))
+ (let ((leaf (tn-leaf tn)))
+ (or (not leaf)
(and
;; Do we not care about preserving this this
;; TN for debugging?
(not (and (lambda-var-p leaf)
(memq (functional-kind (lambda-var-home leaf))
'(nil :optional)))))))
- arg-tn)))))))
+ arg-tn)))))))
;;; Init the sets in BLOCK for copy propagation. To find GEN, we just
;;; look for MOVE vops, and then see whether the result is a eligible
(defun init-copy-sets (block)
(declare (type cblock block))
(let ((kill (make-sset))
- (gen (make-sset)))
+ (gen (make-sset)))
(do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
- ((null vop))
+ ((null vop))
(unless (and (eq (vop-info-name (vop-info vop)) 'move)
- (let ((y (tn-ref-tn (vop-results vop))))
- (when (tn-is-copy-of y)
- (sset-adjoin y gen)
- t)))
+ (let ((y (tn-ref-tn (vop-results vop))))
+ (when (tn-is-copy-of y)
+ (sset-adjoin y gen)
+ t)))
;; WANTED: explanation of UNLESS above.
- (do ((res (vop-results vop) (tn-ref-across res)))
- ((not res))
- (let ((res-tn (tn-ref-tn res)))
- (do ((read (tn-reads res-tn) (tn-ref-next read)))
- ((null read))
- (let ((read-vop (tn-ref-vop read)))
- (when (eq (vop-info-name (vop-info read-vop)) 'move)
- (let ((y (tn-ref-tn (vop-results read-vop))))
- (when (tn-is-copy-of y)
- (sset-delete y gen)
- (sset-adjoin y kill))))))))))
+ (do ((res (vop-results vop) (tn-ref-across res)))
+ ((not res))
+ (let ((res-tn (tn-ref-tn res)))
+ (do ((read (tn-reads res-tn) (tn-ref-next read)))
+ ((null read))
+ (let ((read-vop (tn-ref-vop read)))
+ (when (eq (vop-info-name (vop-info read-vop)) 'move)
+ (let ((y (tn-ref-tn (vop-results read-vop))))
+ (when (tn-is-copy-of y)
+ (sset-delete y gen)
+ (sset-adjoin y kill))))))))))
(setf (block-out block) (copy-sset gen))
(setf (block-kill block) kill)
(setf (block-gen block) gen))
(defun copy-flow-analysis (block)
(declare (type cblock block))
(let* ((pred (block-pred block))
- (in (copy-sset (block-out (first pred)))))
+ (in (copy-sset (block-out (first pred)))))
(dolist (pred-block (rest pred))
(sset-intersection in (block-out pred-block)))
(setf (block-in block) in)
(sset-union-of-difference (block-out block)
- in
- (block-kill block))))
+ in
+ (block-kill block))))
(defevent copy-deleted-move "Copy propagation deleted a move.")
;;; to preserve parallel assignment semantics.
(defun ok-copy-ref (vop arg in original-copy-of)
(declare (type vop vop) (type tn arg) (type sset in)
- (type hash-table original-copy-of))
+ (type hash-table original-copy-of))
(and (sset-member arg in)
(do ((original (gethash arg original-copy-of)
- (gethash original original-copy-of)))
- ((not original) t)
- (unless (sset-member original in)
- (return nil)))
+ (gethash original original-copy-of)))
+ ((not original) t)
+ (unless (sset-member original in)
+ (return nil)))
(let ((info (vop-info vop)))
- (not (and (eq (vop-info-move-args info) :local-call)
- (>= (or (position-in #'tn-ref-across arg (vop-args vop)
- :key #'tn-ref-tn)
- (error "Couldn't find REF?"))
- (length (template-arg-types info))))))))
+ (not (and (eq (vop-info-move-args info) :local-call)
+ (>= (or (position-in #'tn-ref-across arg (vop-args vop)
+ :key #'tn-ref-tn)
+ (error "Couldn't find REF?"))
+ (length (template-arg-types info))))))))
;;; Make use of the result of flow analysis to eliminate copies. We
;;; scan the VOPs in block, propagating copies and keeping our IN set
(declare (type cblock block) (type hash-table original-copy-of))
(let ((in (block-in block)))
(do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
- ((null vop))
+ ((null vop))
(let ((this-copy (and (eq (vop-info-name (vop-info vop)) 'move)
- (let ((y (tn-ref-tn (vop-results vop))))
- (when (tn-is-copy-of y) y)))))
- ;; Substitute copied TN for copy when we find a reference to a copy.
- ;; If the copy is left with no reads, delete the move to the copy.
- (do ((arg-ref (vop-args vop) (tn-ref-across arg-ref)))
- ((null arg-ref))
- (let* ((arg (tn-ref-tn arg-ref))
- (copy-of (tn-is-copy-of arg)))
- (when (and copy-of (ok-copy-ref vop arg in original-copy-of))
- (when this-copy
- (setf (gethash this-copy original-copy-of) arg))
- (change-tn-ref-tn arg-ref copy-of)
- (when (null (tn-reads arg))
- (event copy-deleted-move)
- (delete-vop (tn-ref-vop (tn-writes arg)))))))
- ;; Kill any elements in IN that are copies of a TN we are clobbering.
- (do ((res-ref (vop-results vop) (tn-ref-across res-ref)))
- ((null res-ref))
- (do-sset-elements (tn in)
- (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref))
- (sset-delete tn in))))
- ;; If this VOP is a copy, add the copy TN to IN.
- (when this-copy (sset-adjoin this-copy in)))))
+ (let ((y (tn-ref-tn (vop-results vop))))
+ (when (tn-is-copy-of y) y)))))
+ ;; Substitute copied TN for copy when we find a reference to a copy.
+ ;; If the copy is left with no reads, delete the move to the copy.
+ (do ((arg-ref (vop-args vop) (tn-ref-across arg-ref)))
+ ((null arg-ref))
+ (let* ((arg (tn-ref-tn arg-ref))
+ (copy-of (tn-is-copy-of arg)))
+ (when (and copy-of (ok-copy-ref vop arg in original-copy-of))
+ (when this-copy
+ (setf (gethash this-copy original-copy-of) arg))
+ (change-tn-ref-tn arg-ref copy-of)
+ (when (null (tn-reads arg))
+ (event copy-deleted-move)
+ (delete-vop (tn-ref-vop (tn-writes arg)))))))
+ ;; Kill any elements in IN that are copies of a TN we are clobbering.
+ (do ((res-ref (vop-results vop) (tn-ref-across res-ref)))
+ ((null res-ref))
+ (do-sset-elements (tn in)
+ (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref))
+ (sset-delete tn in))))
+ ;; If this VOP is a copy, add the copy TN to IN.
+ (when this-copy (sset-adjoin this-copy in)))))
(values))
(loop
(let ((did-something nil))
(do-blocks (block component)
- (when (copy-flow-analysis block)
- (setq did-something t)))
+ (when (copy-flow-analysis block)
+ (setq did-something t)))
(unless did-something (return))))
(let ((original-copies (make-hash-table :test 'eq)))
((:lossage-fun *lossage-fun*))
((:unwinnage-fun *unwinnage-fun*)))
(declare (type (or function null) result-test) (type combination call)
- ;; FIXME: Could TYPE here actually be something like
- ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How
- ;; horrible... -- CSR, 2003-05-03
- (type ctype type))
+ ;; FIXME: Could TYPE here actually be something like
+ ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))? How
+ ;; horrible... -- CSR, 2003-05-03
+ (type ctype type))
(let* ((*lossage-detected* nil)
- (*unwinnage-detected* nil)
- (*compiler-error-context* call)
+ (*unwinnage-detected* nil)
+ (*compiler-error-context* call)
(args (combination-args call)))
(if (fun-type-p type)
(let* ((nargs (length args))
((not (constant-type-p type))
(let ((ctype (lvar-type lvar)))
(multiple-value-bind (int win) (funcall *ctype-test-fun* ctype type)
- (cond ((not win)
- (note-unwinnage "can't tell whether the ~:R argument is a ~S"
- n (type-specifier type))
- nil)
- ((not int)
- (note-lossage "The ~:R argument is a ~S, not a ~S."
- n (type-specifier ctype) (type-specifier type))
- nil)
- ((eq ctype *empty-type*)
- (note-unwinnage "The ~:R argument never returns a value." n)
- nil)
- (t t)))))
+ (cond ((not win)
+ (note-unwinnage "can't tell whether the ~:R argument is a ~S"
+ n (type-specifier type))
+ nil)
+ ((not int)
+ (note-lossage "The ~:R argument is a ~S, not a ~S."
+ n (type-specifier ctype) (type-specifier type))
+ nil)
+ ((eq ctype *empty-type*)
+ (note-unwinnage "The ~:R argument never returns a value." n)
+ nil)
+ (t t)))))
((not (constant-lvar-p lvar))
(note-unwinnage "The ~:R argument is not a constant." n)
nil)
(t
(let ((val (lvar-value lvar))
- (type (constant-type-type type)))
+ (type (constant-type-type type)))
(multiple-value-bind (res win) (ctypep val type)
- (cond ((not win)
- (note-unwinnage "can't tell whether the ~:R argument is a ~
+ (cond ((not win)
+ (note-unwinnage "can't tell whether the ~:R argument is a ~
constant ~S:~% ~S"
- n (type-specifier type) val)
- nil)
- ((not res)
- (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
- n (type-specifier type) val)
- nil)
- (t t)))))))
+ n (type-specifier type) val)
+ nil)
+ ((not res)
+ (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
+ n (type-specifier type) val)
+ nil)
+ (t t)))))))
;;; Check that each of the type of each supplied argument intersects
;;; with the type specified for that argument. If we can't tell, then
(n 1 (1+ n)))
((or (null type) (null arg))
(when rest
- (dolist (arg arg)
- (check-arg-type arg rest n)
- (incf n))))
+ (dolist (arg arg)
+ (check-arg-type arg rest n)
+ (incf n))))
(declare (fixnum n))
(check-arg-type (car arg) (car type) n))
(values))
(cond
((not (check-arg-type k (specifier-type 'symbol) n)))
((not (constant-lvar-p k))
- (note-unwinnage "The ~:R argument (in keyword position) is not a ~
+ (note-unwinnage "The ~:R argument (in keyword position) is not a ~
constant."
- n))
+ n))
(t
- (let* ((name (lvar-value k))
- (info (find name (fun-type-keywords type)
- :key #'key-info-name)))
- (cond ((not info)
- (unless (fun-type-allowp type)
- (note-lossage "~S is not a known argument keyword."
- name)))
- (t
- (check-arg-type (second key) (key-info-type info)
- (1+ n)))))))))
+ (let* ((name (lvar-value k))
+ (info (find name (fun-type-keywords type)
+ :key #'key-info-name)))
+ (cond ((not info)
+ (unless (fun-type-allowp type)
+ (note-lossage "~S is not a known argument keyword."
+ name)))
+ (t
+ (check-arg-type (second key) (key-info-type info)
+ (1+ n)))))))))
(values))
;;; Construct a function type from a definition.
:required (mapcar #'leaf-type (lambda-vars functional))
:returns (tail-set-type (lambda-tail-set functional)))
(let ((rest nil))
- (collect ((req)
- (opt)
- (keys))
- (dolist (arg (optional-dispatch-arglist functional))
- (let ((info (lambda-var-arg-info arg))
- (type (leaf-type arg)))
- (if info
- (ecase (arg-info-kind info)
- (:required (req type))
- (:optional (opt type))
- (:keyword
- (keys (make-key-info :name (arg-info-key info)
- :type type)))
- ((:rest :more-context)
- (setq rest *universal-type*))
- (:more-count))
- (req type))))
-
- (make-fun-type
- :required (req)
- :optional (opt)
- :rest rest
- :keywords (keys)
- :keyp (optional-dispatch-keyp functional)
- :allowp (optional-dispatch-allowp functional)
- :returns (tail-set-type
- (lambda-tail-set
- (optional-dispatch-main-entry functional))))))))
+ (collect ((req)
+ (opt)
+ (keys))
+ (dolist (arg (optional-dispatch-arglist functional))
+ (let ((info (lambda-var-arg-info arg))
+ (type (leaf-type arg)))
+ (if info
+ (ecase (arg-info-kind info)
+ (:required (req type))
+ (:optional (opt type))
+ (:keyword
+ (keys (make-key-info :name (arg-info-key info)
+ :type type)))
+ ((:rest :more-context)
+ (setq rest *universal-type*))
+ (:more-count))
+ (req type))))
+
+ (make-fun-type
+ :required (req)
+ :optional (opt)
+ :rest rest
+ :keywords (keys)
+ :keyp (optional-dispatch-keyp functional)
+ :allowp (optional-dispatch-allowp functional)
+ :returns (tail-set-type
+ (lambda-tail-set
+ (optional-dispatch-main-entry functional))))))))
\f
;;;; approximate function types
;;;;
;; the smallest and largest numbers of arguments that this function
;; has been called with.
(min-args sb!xc:call-arguments-limit
- :type (integer 0 #.sb!xc:call-arguments-limit))
+ :type (integer 0 #.sb!xc:call-arguments-limit))
(max-args 0
- :type (integer 0 #.sb!xc:call-arguments-limit))
+ :type (integer 0 #.sb!xc:call-arguments-limit))
;; a list of lists of the all the types that have been used in each
;; argument position
(types () :type list)
;; The position at which this keyword appeared. 0 if it appeared as the
;; first argument, etc.
(position (missing-arg)
- :type (integer 0 #.sb!xc:call-arguments-limit))
+ :type (integer 0 #.sb!xc:call-arguments-limit))
;; a list of all the argument types that have been used with this keyword
(types nil :type list)
;; true if this keyword has appeared only in calls with an obvious
;;; CALL. If TYPE is supplied and not null, then we merge the
;;; information into the information already accumulated in TYPE.
(declaim (ftype (function (combination
- &optional (or approximate-fun-type null))
- approximate-fun-type)
- note-fun-use))
+ &optional (or approximate-fun-type null))
+ approximate-fun-type)
+ note-fun-use))
(defun note-fun-use (call &optional type)
(let* ((type (or type (make-approximate-fun-type)))
- (types (approximate-fun-type-types type))
- (args (combination-args call))
- (nargs (length args))
- (allowp (some (lambda (x)
- (and (constant-lvar-p x)
- (eq (lvar-value x) :allow-other-keys)))
- args)))
+ (types (approximate-fun-type-types type))
+ (args (combination-args call))
+ (nargs (length args))
+ (allowp (some (lambda (x)
+ (and (constant-lvar-p x)
+ (eq (lvar-value x) :allow-other-keys)))
+ args)))
(setf (approximate-fun-type-min-args type)
- (min (approximate-fun-type-min-args type) nargs))
+ (min (approximate-fun-type-min-args type) nargs))
(setf (approximate-fun-type-max-args type)
- (max (approximate-fun-type-max-args type) nargs))
+ (max (approximate-fun-type-max-args type) nargs))
(do ((old types (cdr old))
- (arg args (cdr arg)))
- ((null old)
- (setf (approximate-fun-type-types type)
- (nconc types
- (mapcar (lambda (x)
- (list (lvar-type x)))
- arg))))
+ (arg args (cdr arg)))
+ ((null old)
+ (setf (approximate-fun-type-types type)
+ (nconc types
+ (mapcar (lambda (x)
+ (list (lvar-type x)))
+ arg))))
(when (null arg) (return))
(pushnew (lvar-type (car arg))
- (car old)
- :test #'type=))
+ (car old)
+ :test #'type=))
(collect ((keys (approximate-fun-type-keys type) cons))
(do ((arg args (cdr arg))
- (pos 0 (1+ pos)))
- ((or (null arg) (null (cdr arg)))
- (setf (approximate-fun-type-keys type) (keys)))
- (let ((key (first arg))
- (val (second arg)))
- (when (constant-lvar-p key)
- (let ((name (lvar-value key)))
- (when (keywordp name)
- (let ((old (find-if
- (lambda (x)
- (and (eq (approximate-key-info-name x) name)
- (= (approximate-key-info-position x)
- pos)))
- (keys)))
- (val-type (lvar-type val)))
- (cond (old
- (pushnew val-type
- (approximate-key-info-types old)
- :test #'type=)
- (unless allowp
- (setf (approximate-key-info-allowp old) nil)))
- (t
- (keys (make-approximate-key-info
- :name name
- :position pos
- :allowp allowp
- :types (list val-type))))))))))))
+ (pos 0 (1+ pos)))
+ ((or (null arg) (null (cdr arg)))
+ (setf (approximate-fun-type-keys type) (keys)))
+ (let ((key (first arg))
+ (val (second arg)))
+ (when (constant-lvar-p key)
+ (let ((name (lvar-value key)))
+ (when (keywordp name)
+ (let ((old (find-if
+ (lambda (x)
+ (and (eq (approximate-key-info-name x) name)
+ (= (approximate-key-info-position x)
+ pos)))
+ (keys)))
+ (val-type (lvar-type val)))
+ (cond (old
+ (pushnew val-type
+ (approximate-key-info-types old)
+ :test #'type=)
+ (unless allowp
+ (setf (approximate-key-info-allowp old) nil)))
+ (t
+ (keys (make-approximate-key-info
+ :name name
+ :position pos
+ :allowp allowp
+ :types (list val-type))))))))))))
type))
;;; This is similar to VALID-FUN-USE, but checks an
;;; APPROXIMATE-FUN-TYPE against a real function type.
(declaim (ftype (function (approximate-fun-type fun-type
- &optional function function function)
- (values boolean boolean))
- valid-approximate-type))
+ &optional function function function)
+ (values boolean boolean))
+ valid-approximate-type))
(defun valid-approximate-type (call-type type &optional
- (*ctype-test-fun*
- #'types-equal-or-intersect)
- (*lossage-fun*
- #'compiler-style-warn)
- (*unwinnage-fun* #'compiler-notify))
+ (*ctype-test-fun*
+ #'types-equal-or-intersect)
+ (*lossage-fun*
+ #'compiler-style-warn)
+ (*unwinnage-fun* #'compiler-notify))
(let* ((*lossage-detected* nil)
- (*unwinnage-detected* nil)
- (required (fun-type-required type))
- (min-args (length required))
- (optional (fun-type-optional type))
- (max-args (+ min-args (length optional)))
- (rest (fun-type-rest type))
- (keyp (fun-type-keyp type)))
+ (*unwinnage-detected* nil)
+ (required (fun-type-required type))
+ (min-args (length required))
+ (optional (fun-type-optional type))
+ (max-args (+ min-args (length optional)))
+ (rest (fun-type-rest type))
+ (keyp (fun-type-keyp type)))
(when (fun-type-wild-args type)
(return-from valid-approximate-type (values t t)))
(let ((call-min (approximate-fun-type-min-args call-type)))
(when (< call-min min-args)
- (note-lossage
- "~:@<The function was previously called with ~R argument~:P, ~
+ (note-lossage
+ "~:@<The function was previously called with ~R argument~:P, ~
but wants at least ~R.~:>"
- call-min min-args)))
+ call-min min-args)))
(let ((call-max (approximate-fun-type-max-args call-type)))
(cond ((<= call-max max-args))
- ((not (or keyp rest))
- (note-lossage
- "~:@<The function was previously called with ~R argument~:P, ~
+ ((not (or keyp rest))
+ (note-lossage
+ "~:@<The function was previously called with ~R argument~:P, ~
but wants at most ~R.~:>"
- call-max max-args))
- ((and keyp (oddp (- call-max max-args)))
- (note-lossage
- "~:@<The function was previously called with an odd number of ~
+ call-max max-args))
+ ((and keyp (oddp (- call-max max-args)))
+ (note-lossage
+ "~:@<The function was previously called with an odd number of ~
arguments in the keyword portion.~:>")))
(when (and keyp (> call-max max-args))
- (check-approximate-keywords call-type max-args type)))
+ (check-approximate-keywords call-type max-args type)))
(check-approximate-fixed-and-rest call-type (append required optional)
- rest)
+ rest)
(cond (*lossage-detected* (values nil t))
- (*unwinnage-detected* (values nil nil))
- (t (values t t)))))
+ (*unwinnage-detected* (values nil nil))
+ (t (values t t)))))
;;; Check that each of the types used at each arg position is
;;; compatible with the actual type.
(declaim (ftype (function (approximate-fun-type list (or ctype null))
- (values))
- check-approximate-fixed-and-rest))
+ (values))
+ check-approximate-fixed-and-rest))
(defun check-approximate-fixed-and-rest (call-type fixed rest)
(do ((types (approximate-fun-type-types call-type) (cdr types))
(n 1 (1+ n))
;;; Check that each of the call-types is compatible with DECL-TYPE,
;;; complaining if not or if we can't tell.
(declaim (ftype (function (list ctype string &rest t) (values))
- check-approximate-arg-type))
+ check-approximate-arg-type))
(defun check-approximate-arg-type (call-types decl-type context &rest args)
(let ((losers *empty-type*))
(dolist (ctype call-types)
(multiple-value-bind (int win) (funcall *ctype-test-fun* ctype decl-type)
- (cond
- ((not win)
- (note-unwinnage "can't tell whether previous ~? ~
+ (cond
+ ((not win)
+ (note-unwinnage "can't tell whether previous ~? ~
argument type ~S is a ~S"
- context
- args
- (type-specifier ctype)
- (type-specifier decl-type)))
- ((not int)
- (setq losers (type-union ctype losers))))))
+ context
+ args
+ (type-specifier ctype)
+ (type-specifier decl-type)))
+ ((not int)
+ (setq losers (type-union ctype losers))))))
(unless (eq losers *empty-type*)
(note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
- context args (type-specifier decl-type) (type-specifier losers))))
+ context args (type-specifier decl-type) (type-specifier losers))))
(values))
;;; Check the types of each manifest keyword that appears in a keyword
;;; keywords.
(defun check-approximate-keywords (call-type max-args type)
(let ((call-keys (approximate-fun-type-keys call-type))
- (keys (fun-type-keywords type)))
+ (keys (fun-type-keywords type)))
(dolist (key keys)
(let ((name (key-info-name key)))
- (collect ((types nil append))
- (dolist (call-key call-keys)
- (let ((pos (approximate-key-info-position call-key)))
- (when (and (eq (approximate-key-info-name call-key) name)
- (> pos max-args) (evenp (- pos max-args)))
- (types (approximate-key-info-types call-key)))))
- (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
+ (collect ((types nil append))
+ (dolist (call-key call-keys)
+ (let ((pos (approximate-key-info-position call-key)))
+ (when (and (eq (approximate-key-info-name call-key) name)
+ (> pos max-args) (evenp (- pos max-args)))
+ (types (approximate-key-info-types call-key)))))
+ (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
(unless (fun-type-allowp type)
(collect ((names () adjoin))
- (dolist (call-key call-keys)
- (let ((pos (approximate-key-info-position call-key)))
- (when (and (> pos max-args) (evenp (- pos max-args))
- (not (approximate-key-info-allowp call-key)))
- (names (approximate-key-info-name call-key)))))
-
- (dolist (name (names))
- (unless (find name keys :key #'key-info-name)
- (note-lossage "Function previously called with unknown argument keyword ~S."
- name)))))))
+ (dolist (call-key call-keys)
+ (let ((pos (approximate-key-info-position call-key)))
+ (when (and (> pos max-args) (evenp (- pos max-args))
+ (not (approximate-key-info-allowp call-key)))
+ (names (approximate-key-info-name call-key)))))
+
+ (dolist (name (names))
+ (unless (find name keys :key #'key-info-name)
+ (note-lossage "Function previously called with unknown argument keyword ~S."
+ name)))))))
\f
;;;; ASSERT-DEFINITION-TYPE
(declare (list vars types) (string where))
(collect ((res))
(mapc (lambda (var type)
- (let* ((vtype (leaf-type var))
- (int (type-approx-intersection2 vtype type)))
- (cond
- ((eq int *empty-type*)
- (note-lossage
- "Definition's declared type for variable ~A:~% ~S~@
+ (let* ((vtype (leaf-type var))
+ (int (type-approx-intersection2 vtype type)))
+ (cond
+ ((eq int *empty-type*)
+ (note-lossage
+ "Definition's declared type for variable ~A:~% ~S~@
conflicts with this type from ~A:~% ~S"
- (leaf-debug-name var) (type-specifier vtype)
- where (type-specifier type))
- (return-from try-type-intersections (values nil nil)))
- (t
- (res int)))))
- vars types)
+ (leaf-debug-name var) (type-specifier vtype)
+ where (type-specifier type))
+ (return-from try-type-intersections (values nil nil)))
+ (t
+ (res int)))))
+ vars types)
(values vars (res))))
;;; Check that the optional-dispatch OD conforms to TYPE. We return
;;; assertion.
(defun find-optional-dispatch-types (od type where)
(declare (type optional-dispatch od)
- (type fun-type type)
- (string where))
+ (type fun-type type)
+ (string where))
(let* ((min (optional-dispatch-min-args od))
- (req (fun-type-required type))
- (opt (fun-type-optional type)))
+ (req (fun-type-required type))
+ (opt (fun-type-optional type)))
(flet ((frob (x y what)
- (unless (= x y)
- (note-lossage
- "The definition has ~R ~A arg~P, but ~A has ~R."
- x what x where y))))
+ (unless (= x y)
+ (note-lossage
+ "The definition has ~R ~A arg~P, but ~A has ~R."
+ x what x where y))))
(frob min (length req) "fixed")
(frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
(flet ((frob (x y what)
- (unless (eq x y)
- (note-lossage
- "The definition ~:[doesn't have~;has~] ~A, but ~
+ (unless (eq x y)
+ (note-lossage
+ "The definition ~:[doesn't have~;has~] ~A, but ~
~A ~:[doesn't~;does~]."
- x what where y))))
+ x what where y))))
(frob (optional-dispatch-keyp od) (fun-type-keyp type)
- "&KEY arguments")
+ "&KEY arguments")
(unless (optional-dispatch-keyp od)
- (frob (not (null (optional-dispatch-more-entry od)))
- (not (null (fun-type-rest type)))
- "&REST arguments"))
+ (frob (not (null (optional-dispatch-more-entry od)))
+ (not (null (fun-type-rest type)))
+ "&REST arguments"))
(frob (optional-dispatch-allowp od) (fun-type-allowp type)
- "&ALLOW-OTHER-KEYS"))
+ "&ALLOW-OTHER-KEYS"))
(when *lossage-detected*
(return-from find-optional-dispatch-types (values nil nil)))
(collect ((res)
- (vars))
+ (vars))
(let ((keys (fun-type-keywords type))
- (arglist (optional-dispatch-arglist od)))
- (dolist (arg arglist)
- (cond
- ((lambda-var-arg-info arg)
- (let* ((info (lambda-var-arg-info arg))
- (default (arg-info-default info))
- (def-type (when (constantp default)
- (ctype-of (eval default)))))
- (ecase (arg-info-kind info)
- (:keyword
- (let* ((key (arg-info-key info))
- (kinfo (find key keys :key #'key-info-name)))
- (cond
- (kinfo
- (res (type-union (key-info-type kinfo)
- (or def-type (specifier-type 'null)))))
- (t
- (note-lossage
- "Defining a ~S keyword not present in ~A."
- key where)
- (res *universal-type*)))))
- (:required (res (pop req)))
- (:optional
- (res (type-union (pop opt) (or def-type *universal-type*))))
- (:rest
- (when (fun-type-rest type)
- (res (specifier-type 'list))))
- (:more-context
- (when (fun-type-rest type)
- (res *universal-type*)))
- (:more-count
- (when (fun-type-rest type)
- (res (specifier-type 'fixnum)))))
- (vars arg)
- (when (arg-info-supplied-p info)
- (res *universal-type*)
- (vars (arg-info-supplied-p info)))))
- (t
- (res (pop req))
- (vars arg))))
-
- (dolist (key keys)
- (unless (find (key-info-name key) arglist
- :key (lambda (x)
- (let ((info (lambda-var-arg-info x)))
- (when info
- (arg-info-key info)))))
- (note-lossage
- "The definition lacks the ~S key present in ~A."
- (key-info-name key) where))))
+ (arglist (optional-dispatch-arglist od)))
+ (dolist (arg arglist)
+ (cond
+ ((lambda-var-arg-info arg)
+ (let* ((info (lambda-var-arg-info arg))
+ (default (arg-info-default info))
+ (def-type (when (constantp default)
+ (ctype-of (eval default)))))
+ (ecase (arg-info-kind info)
+ (:keyword
+ (let* ((key (arg-info-key info))
+ (kinfo (find key keys :key #'key-info-name)))
+ (cond
+ (kinfo
+ (res (type-union (key-info-type kinfo)
+ (or def-type (specifier-type 'null)))))
+ (t
+ (note-lossage
+ "Defining a ~S keyword not present in ~A."
+ key where)
+ (res *universal-type*)))))
+ (:required (res (pop req)))
+ (:optional
+ (res (type-union (pop opt) (or def-type *universal-type*))))
+ (:rest
+ (when (fun-type-rest type)
+ (res (specifier-type 'list))))
+ (:more-context
+ (when (fun-type-rest type)
+ (res *universal-type*)))
+ (:more-count
+ (when (fun-type-rest type)
+ (res (specifier-type 'fixnum)))))
+ (vars arg)
+ (when (arg-info-supplied-p info)
+ (res *universal-type*)
+ (vars (arg-info-supplied-p info)))))
+ (t
+ (res (pop req))
+ (vars arg))))
+
+ (dolist (key keys)
+ (unless (find (key-info-name key) arglist
+ :key (lambda (x)
+ (let ((info (lambda-var-arg-info x)))
+ (when info
+ (arg-info-key info)))))
+ (note-lossage
+ "The definition lacks the ~S key present in ~A."
+ (key-info-name key) where))))
(try-type-intersections (vars) (res) where))))
(defun find-lambda-types (lambda type where)
(declare (type clambda lambda) (type fun-type type) (string where))
(flet ((frob (x what)
- (when x
- (note-lossage
- "The definition has no ~A, but the ~A did."
- what where))))
+ (when x
+ (note-lossage
+ "The definition has no ~A, but the ~A did."
+ what where))))
(frob (fun-type-optional type) "&OPTIONAL arguments")
(frob (fun-type-keyp type) "&KEY arguments")
(frob (fun-type-rest type) "&REST argument"))
(let* ((vars (lambda-vars lambda))
- (nvars (length vars))
- (req (fun-type-required type))
- (nreq (length req)))
+ (nvars (length vars))
+ (req (fun-type-required type))
+ (nreq (length req)))
(unless (= nvars nreq)
(note-lossage "The definition has ~R arg~:P, but the ~A has ~R."
- nvars where nreq))
+ nvars where nreq))
(if *lossage-detected*
- (values nil nil)
- (try-type-intersections vars req where))))
+ (values nil nil)
+ (try-type-intersections vars req where))))
;;; Check for syntactic and type conformance between the definition
;;; FUNCTIONAL and the specified FUN-TYPE. If they are compatible
unwinnage-fun
(where "previous declaration"))
(declare (type functional functional)
- (type function *lossage-fun*)
- (string where))
+ (type function *lossage-fun*)
+ (string where))
(unless (fun-type-p type)
(return-from assert-definition-type t))
(let ((*lossage-detected* nil))
(multiple-value-bind (vars types)
- (if (fun-type-wild-args type)
- (values nil nil)
- (etypecase functional
- (optional-dispatch
- (find-optional-dispatch-types functional type where))
- (clambda
- (find-lambda-types functional type where))))
+ (if (fun-type-wild-args type)
+ (values nil nil)
+ (etypecase functional
+ (optional-dispatch
+ (find-optional-dispatch-types functional type where))
+ (clambda
+ (find-lambda-types functional type where))))
(let* ((type-returns (fun-type-returns type))
- (return (lambda-return (main-entry functional)))
- (dtype (when return
+ (return (lambda-return (main-entry functional)))
+ (dtype (when return
(lvar-derived-type (return-result return)))))
- (cond
+ (cond
((and dtype (not (values-types-equal-or-intersect dtype
type-returns)))
(note-lossage
(compiler-style-warn "~@<using ~S of type ~S as a catch tag (which ~
tends to be unportable because THROW and CATCH ~
use EQ comparison)~@:>"
- (lvar-source tag)
- (type-specifier (lvar-type tag))))))
+ (lvar-source tag)
+ (type-specifier (lvar-type tag))))))
(defun %compile-time-type-error (values atype dtype)
(declare (ignore dtype))
(dtype (lvar-value dtype)))
(unless (eq atype nil)
(warn 'type-warning
- :format-control
- "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
- :format-arguments (list atype dtype)))))
+ :format-control
+ "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
+ :format-arguments (list atype dtype)))))
(ir2-convert-full-call node block)))
(deftype location-kind ()
'(member :unknown-return :known-return :internal-error :non-local-exit
- :block-start :call-site :single-value-return :non-local-entry))
+ :block-start :call-site :single-value-return :non-local-entry))
;;; The LOCATION-INFO structure holds the information what we need
;;; about locations which code generation decided were "interesting".
(defstruct (location-info
- (:constructor make-location-info (kind label vop))
- (:copier nil))
+ (:constructor make-location-info (kind label vop))
+ (:copier nil))
;; The kind of location noted.
(kind nil :type location-kind)
;; The label pointing to the interesting code location.
;;; in the debugger, and thus want debug info.
(defun note-debug-location (vop label kind)
(declare (type vop vop) (type (or label null) label)
- (type location-kind kind))
+ (type location-kind kind))
(let ((location (make-location-info kind label vop)))
(setf (ir2-block-locations (vop-block vop))
- (nconc (ir2-block-locations (vop-block vop))
- (list location)))
+ (nconc (ir2-block-locations (vop-block vop))
+ (list location)))
location))
#!-sb-fluid (declaim (inline ir2-block-physenv))
;;; live when it is in scope at NODE.
(defun compute-live-vars (live node block var-locs vop)
(declare (type ir2-block block) (type local-tn-bit-vector live)
- (type hash-table var-locs) (type node node)
- (type (or vop null) vop))
+ (type hash-table var-locs) (type node node)
+ (type (or vop null) vop))
(let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
- :element-type 'bit
- :initial-element 0))
- (spilled (gethash vop
- (ir2-component-spilled-vops
- (component-info *component-being-compiled*)))))
+ :element-type 'bit
+ :initial-element 0))
+ (spilled (gethash vop
+ (ir2-component-spilled-vops
+ (component-info *component-being-compiled*)))))
(do-live-tns (tn live block)
(let ((leaf (tn-leaf tn)))
- (when (and (lambda-var-p leaf)
- (or (not (member (tn-kind tn)
- '(:environment :debug-environment)))
- (rassoc leaf (lexenv-vars (node-lexenv node))))
- (or (null spilled)
- (not (member tn spilled))))
- (let ((num (gethash leaf var-locs)))
- (when num
- (setf (sbit res num) 1))))))
+ (when (and (lambda-var-p leaf)
+ (or (not (member (tn-kind tn)
+ '(:environment :debug-environment)))
+ (rassoc leaf (lexenv-vars (node-lexenv node))))
+ (or (null spilled)
+ (not (member tn spilled))))
+ (let ((num (gethash leaf var-locs)))
+ (when num
+ (setf (sbit res num) 1))))))
res))
;;; The PC for the location most recently dumped.
;;; are spilled.
(defun dump-1-location (node block kind tlf-num label live var-locs vop)
(declare (type node node) (type ir2-block block)
- (type local-tn-bit-vector live)
- (type (or label index) label)
- (type location-kind kind) (type (or index null) tlf-num)
- (type hash-table var-locs) (type (or vop null) vop))
+ (type local-tn-bit-vector live)
+ (type (or label index) label)
+ (type location-kind kind) (type (or index null) tlf-num)
+ (type hash-table var-locs) (type (or vop null) vop))
(vector-push-extend
(dpb (position-or-lose kind *compiled-code-location-kinds*)
- compiled-code-location-kind-byte
- 0)
+ compiled-code-location-kind-byte
+ 0)
*byte-buffer*)
(let ((loc (if (fixnump label) label (label-position label))))
(write-var-integer (source-path-form-number path) *byte-buffer*))
(write-packed-bit-vector (compute-live-vars live node block var-locs vop)
- *byte-buffer*)
+ *byte-buffer*)
(values))
;;; dump a compiled code-location.
(defun dump-location-from-info (loc tlf-num var-locs)
(declare (type location-info loc) (type (or index null) tlf-num)
- (type hash-table var-locs))
+ (type hash-table var-locs))
(let ((vop (location-info-vop loc)))
(dump-1-location (vop-node vop)
- (vop-block vop)
- (location-info-kind loc)
- tlf-num
- (location-info-label loc)
- (vop-save-set vop)
- var-locs
- vop))
+ (vop-block vop)
+ (location-info-kind loc)
+ tlf-num
+ (location-info-label loc)
+ (vop-save-set vop)
+ var-locs
+ vop))
(values))
;;; Scan all the blocks, determining if all locations are in the same
(declare (type (or index null) res))
(do-physenv-ir2-blocks (2block (lambda-physenv fun))
(let ((block (ir2-block-block 2block)))
- (when (eq (block-info block) 2block)
- (unless (eql (source-path-tlf-number
- (node-source-path
- (block-start-node block)))
- res)
- (setq res nil)))
-
- (dolist (loc (ir2-block-locations 2block))
- (unless (eql (source-path-tlf-number
- (node-source-path
- (vop-node (location-info-vop loc))))
- res)
- (setq res nil)))))
+ (when (eq (block-info block) 2block)
+ (unless (eql (source-path-tlf-number
+ (node-source-path
+ (block-start-node block)))
+ res)
+ (setq res nil)))
+
+ (dolist (loc (ir2-block-locations 2block))
+ (unless (eql (source-path-tlf-number
+ (node-source-path
+ (vop-node (location-info-vop loc))))
+ res)
+ (setq res nil)))))
res))
;;; Dump out the number of locations and the locations for Block.
(defun dump-block-locations (block locations tlf-num var-locs)
(declare (type cblock block) (list locations))
(if (and locations
- (eq (location-info-kind (first locations))
- :non-local-entry))
+ (eq (location-info-kind (first locations))
+ :non-local-entry))
(write-var-integer (length locations) *byte-buffer*)
(let ((2block (block-info block)))
- (write-var-integer (+ (length locations) 1) *byte-buffer*)
- (dump-1-location (block-start-node block)
- 2block :block-start tlf-num
- (ir2-block-%label 2block)
- (ir2-block-live-out 2block)
- var-locs
- nil)))
+ (write-var-integer (+ (length locations) 1) *byte-buffer*)
+ (dump-1-location (block-start-node block)
+ 2block :block-start tlf-num
+ (ir2-block-%label 2block)
+ (ir2-block-live-out 2block)
+ var-locs
+ nil)))
(dolist (loc locations)
(dump-location-from-info loc tlf-num var-locs))
(values))
(defun dump-block-successors (block physenv)
(declare (type cblock block) (type physenv physenv))
(let* ((tail (component-tail (block-component block)))
- (succ (block-succ block))
- (valid-succ
- (if (and succ
- (or (eq (car succ) tail)
- (not (eq (block-physenv (car succ)) physenv))))
- ()
- succ)))
+ (succ (block-succ block))
+ (valid-succ
+ (if (and succ
+ (or (eq (car succ) tail)
+ (not (eq (block-physenv (car succ)) physenv))))
+ ()
+ succ)))
(vector-push-extend
(dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
*byte-buffer*)
(let ((base (block-number
- (node-block
- (lambda-bind (physenv-lambda physenv))))))
+ (node-block
+ (lambda-bind (physenv-lambda physenv))))))
(dolist (b valid-succ)
- (write-var-integer
- (the index (- (block-number b) base))
- *byte-buffer*))))
+ (write-var-integer
+ (the index (- (block-number b) base))
+ *byte-buffer*))))
(values))
;;; Return a vector and an integer (or null) suitable for use as the
;;; passes to compute:
;;; -- Scan all blocks, dumping the header and successors followed
;;; by all the non-elsewhere locations.
-;;; -- Dump the elsewhere block header and all the elsewhere
+;;; -- Dump the elsewhere block header and all the elsewhere
;;; locations (if any.)
(defun compute-debug-blocks (fun var-locs)
(declare (type clambda fun) (type hash-table var-locs))
(setf (fill-pointer *byte-buffer*) 0)
(let ((*previous-location* 0)
- (tlf-num (find-tlf-number fun))
- (physenv (lambda-physenv fun))
- (prev-locs nil)
- (prev-block nil))
+ (tlf-num (find-tlf-number fun))
+ (physenv (lambda-physenv fun))
+ (prev-locs nil)
+ (prev-block nil))
(collect ((elsewhere))
(do-physenv-ir2-blocks (2block physenv)
- (let ((block (ir2-block-block 2block)))
- (when (eq (block-info block) 2block)
- (when prev-block
- (dump-block-locations prev-block prev-locs tlf-num var-locs))
- (setq prev-block block prev-locs ())
- (dump-block-successors block physenv)))
-
- (collect ((here prev-locs))
- (dolist (loc (ir2-block-locations 2block))
- (if (label-elsewhere-p (location-info-label loc))
- (elsewhere loc)
- (here loc)))
- (setq prev-locs (here))))
+ (let ((block (ir2-block-block 2block)))
+ (when (eq (block-info block) 2block)
+ (when prev-block
+ (dump-block-locations prev-block prev-locs tlf-num var-locs))
+ (setq prev-block block prev-locs ())
+ (dump-block-successors block physenv)))
+
+ (collect ((here prev-locs))
+ (dolist (loc (ir2-block-locations 2block))
+ (if (label-elsewhere-p (location-info-label loc))
+ (elsewhere loc)
+ (here loc)))
+ (setq prev-locs (here))))
(dump-block-locations prev-block prev-locs tlf-num var-locs)
(when (elsewhere)
- (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
- (write-var-integer (length (elsewhere)) *byte-buffer*)
- (dolist (loc (elsewhere))
- (dump-location-from-info loc tlf-num var-locs))))
+ (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
+ (write-var-integer (length (elsewhere)) *byte-buffer*)
+ (dolist (loc (elsewhere))
+ (dump-location-from-info loc tlf-num var-locs))))
(values (copy-seq *byte-buffer*) tlf-num)))
\f
;;; Return DEBUG-SOURCE structure containing information derived from
-;;; INFO.
+;;; INFO.
(defun debug-source-for-info (info)
(declare (type source-info info))
(let* ((file-info (source-info-file-info info))
- (res (make-debug-source
- :from :file
- :created (file-info-write-date file-info)
- :compiled (source-info-start-time info)
- :source-root (file-info-source-root file-info)
- :start-positions (coerce-to-smallest-eltype
- (file-info-positions file-info))))
- (name (file-info-name file-info)))
+ (res (make-debug-source
+ :from :file
+ :created (file-info-write-date file-info)
+ :compiled (source-info-start-time info)
+ :source-root (file-info-source-root file-info)
+ :start-positions (coerce-to-smallest-eltype
+ (file-info-positions file-info))))
+ (name (file-info-name file-info)))
(etypecase name
((member :lisp)
(setf (debug-source-from res) name
- (debug-source-name res) (file-info-forms file-info)))
+ (debug-source-name res) (file-info-forms file-info)))
(pathname
(let* ((untruename (file-info-untruename file-info))
- (dir (pathname-directory untruename)))
- (setf (debug-source-name res)
- #+sb-xc-host
- (let ((src (position "src" dir :test #'string= :from-end t)))
- (if src
- (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
- (subseq dir src) (pathname-name untruename))
- ;; FIXME: just output/stuff-groveled-from-headers.lisp
- (namestring untruename)))
- #-sb-xc-host
- (namestring
- (if (and dir (eq (first dir) :absolute))
- untruename
- name))))))
+ (dir (pathname-directory untruename)))
+ (setf (debug-source-name res)
+ #+sb-xc-host
+ (let ((src (position "src" dir :test #'string= :from-end t)))
+ (if src
+ (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
+ (subseq dir src) (pathname-name untruename))
+ ;; FIXME: just output/stuff-groveled-from-headers.lisp
+ (namestring untruename)))
+ #-sb-xc-host
+ (namestring
+ (if (and dir (eq (first dir) :absolute))
+ untruename
+ name))))))
res))
;;; Given an arbitrary sequence, coerce it to an unsigned vector if
(defun coerce-to-smallest-eltype (seq)
(let ((maxoid 0))
(flet ((frob (x)
- (if (typep x 'unsigned-byte)
- (when (>= x maxoid)
- (setf maxoid x))
- (return-from coerce-to-smallest-eltype
- (coerce seq 'simple-vector)))))
+ (if (typep x 'unsigned-byte)
+ (when (>= x maxoid)
+ (setf maxoid x))
+ (return-from coerce-to-smallest-eltype
+ (coerce seq 'simple-vector)))))
(if (listp seq)
- (dolist (i seq)
- (frob i))
- (dovector (i seq)
- (frob i)))
+ (dolist (i seq)
+ (frob i))
+ (dovector (i seq)
+ (frob i)))
(let ((specializer `(unsigned-byte
- ,(etypecase maxoid
- ((unsigned-byte 8) 8)
- ((unsigned-byte 16) 16)
- ((unsigned-byte 32) 32)))))
- ;; cross-compilers beware! It would be possible for the
- ;; upgraded-array-element-type of (UNSIGNED-BYTE 16) to be
- ;; (SIGNED-BYTE 17) or (UNSIGNED-BYTE 23), and this is
- ;; completely valid by ANSI. However, the cross-compiler
- ;; doesn't know how to dump (in practice) anything but the
- ;; above three specialized array types, so make it break here
- ;; if this is violated.
- #+sb-xc-host
- (aver
- ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are
- ;; worried about whether the host's implementation of arrays.
- (let ((uaet (upgraded-array-element-type specializer)))
- (dolist (et '((unsigned-byte 8)
- (unsigned-byte 16)
- (unsigned-byte 32))
- nil)
- (when (and (subtypep et uaet) (subtypep uaet et))
- (return t)))))
- (coerce seq `(simple-array ,specializer (*)))))))
+ ,(etypecase maxoid
+ ((unsigned-byte 8) 8)
+ ((unsigned-byte 16) 16)
+ ((unsigned-byte 32) 32)))))
+ ;; cross-compilers beware! It would be possible for the
+ ;; upgraded-array-element-type of (UNSIGNED-BYTE 16) to be
+ ;; (SIGNED-BYTE 17) or (UNSIGNED-BYTE 23), and this is
+ ;; completely valid by ANSI. However, the cross-compiler
+ ;; doesn't know how to dump (in practice) anything but the
+ ;; above three specialized array types, so make it break here
+ ;; if this is violated.
+ #+sb-xc-host
+ (aver
+ ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are
+ ;; worried about whether the host's implementation of arrays.
+ (let ((uaet (upgraded-array-element-type specializer)))
+ (dolist (et '((unsigned-byte 8)
+ (unsigned-byte 16)
+ (unsigned-byte 32))
+ nil)
+ (when (and (subtypep et uaet) (subtypep uaet et))
+ (return t)))))
+ (coerce seq `(simple-array ,specializer (*)))))))
\f
;;;; variables
(defun tn-sc-offset (tn)
(declare (type tn tn))
(make-sc-offset (sc-number (tn-sc tn))
- (tn-offset tn)))
+ (tn-offset tn)))
;;; Dump info to represent VAR's location being TN. ID is an integer
;;; that makes VAR's name unique in the function. BUFFER is the vector
;;; guaranteed to be live everywhere in that case.
(defun dump-1-var (fun var tn id minimal buffer)
(declare (type lambda-var var) (type (or tn null) tn) (type index id)
- (type clambda fun))
+ (type clambda fun))
(let* ((name (leaf-debug-name var))
- (save-tn (and tn (tn-save-tn tn)))
- (kind (and tn (tn-kind tn)))
- (flags 0))
+ (save-tn (and tn (tn-save-tn tn)))
+ (kind (and tn (tn-kind tn)))
+ (flags 0))
(declare (type index flags))
(when minimal
(setq flags (logior flags compiled-debug-var-minimal-p))
(unless tn
- (setq flags (logior flags compiled-debug-var-deleted-p))))
+ (setq flags (logior flags compiled-debug-var-deleted-p))))
(when (and (or (eq kind :environment)
- (and (eq kind :debug-environment)
- (null (basic-var-sets var))))
- (not (gethash tn (ir2-component-spilled-tns
- (component-info *component-being-compiled*))))
- (eq (lambda-var-home var) fun))
+ (and (eq kind :debug-environment)
+ (null (basic-var-sets var))))
+ (not (gethash tn (ir2-component-spilled-tns
+ (component-info *component-being-compiled*))))
+ (eq (lambda-var-home var) fun))
(setq flags (logior flags compiled-debug-var-environment-live)))
(when save-tn
(setq flags (logior flags compiled-debug-var-save-loc-p)))
(unless minimal
(vector-push-extend name buffer)
(unless (zerop id)
- (vector-push-extend id buffer)))
+ (vector-push-extend id buffer)))
(if tn
- (vector-push-extend (tn-sc-offset tn) buffer)
- (aver minimal))
+ (vector-push-extend (tn-sc-offset tn) buffer)
+ (aver minimal))
(when save-tn
(vector-push-extend (tn-sc-offset save-tn) buffer)))
(values))
(declare (type clambda fun) (type hash-table var-locs))
(collect ((vars))
(labels ((frob-leaf (leaf tn gensym-p)
- (let ((name (leaf-debug-name leaf)))
- (when (and name (leaf-refs leaf) (tn-offset tn)
- (or gensym-p (symbol-package name)))
- (vars (cons leaf tn)))))
- (frob-lambda (x gensym-p)
- (dolist (leaf (lambda-vars x))
- (frob-leaf leaf (leaf-info leaf) gensym-p))))
+ (let ((name (leaf-debug-name leaf)))
+ (when (and name (leaf-refs leaf) (tn-offset tn)
+ (or gensym-p (symbol-package name)))
+ (vars (cons leaf tn)))))
+ (frob-lambda (x gensym-p)
+ (dolist (leaf (lambda-vars x))
+ (frob-leaf leaf (leaf-info leaf) gensym-p))))
(frob-lambda fun t)
(when (>= level 2)
- (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun))))
- (let ((thing (car x)))
- (when (lambda-var-p thing)
- (frob-leaf thing (cdr x) (= level 3)))))
-
- (dolist (let (lambda-lets fun))
- (frob-lambda let (= level 3)))))
+ (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun))))
+ (let ((thing (car x)))
+ (when (lambda-var-p thing)
+ (frob-leaf thing (cdr x) (= level 3)))))
+
+ (dolist (let (lambda-lets fun))
+ (frob-lambda let (= level 3)))))
(let ((sorted (sort (vars) #'string<
- :key (lambda (x)
- (symbol-name (leaf-debug-name (car x))))))
- (prev-name nil)
- (id 0)
- (i 0)
- (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
+ :key (lambda (x)
+ (symbol-name (leaf-debug-name (car x))))))
+ (prev-name nil)
+ (id 0)
+ (i 0)
+ (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
(declare (type (or simple-string null) prev-name)
- (type index id i))
+ (type index id i))
(dolist (x sorted)
- (let* ((var (car x))
- (name (symbol-name (leaf-debug-name var))))
- (cond ((and prev-name (string= prev-name name))
- (incf id))
- (t
- (setq id 0 prev-name name)))
- (dump-1-var fun var (cdr x) id nil buffer)
- (setf (gethash var var-locs) i))
- (incf i))
+ (let* ((var (car x))
+ (name (symbol-name (leaf-debug-name var))))
+ (cond ((and prev-name (string= prev-name name))
+ (incf id))
+ (t
+ (setq id 0 prev-name name)))
+ (dump-1-var fun var (cdr x) id nil buffer)
+ (setf (gethash var var-locs) i))
+ (incf i))
(coerce buffer 'simple-vector))))
;;; Return a vector suitable for use as the DEBUG-FUN-VARS of
(declare (type lambda-var var) (type hash-table var-locs))
(let ((res (gethash var var-locs)))
(cond (res)
- (t
- (aver (or (null (leaf-refs var))
- (not (tn-offset (leaf-info var)))))
- 'deleted))))
+ (t
+ (aver (or (null (leaf-refs var))
+ (not (tn-offset (leaf-info var)))))
+ 'deleted))))
\f
;;;; arguments/returns
(collect ((res))
(let ((od (lambda-optional-dispatch fun)))
(if (and od (eq (optional-dispatch-main-entry od) fun))
- (let ((actual-vars (lambda-vars fun))
- (saw-optional nil))
- (dolist (arg (optional-dispatch-arglist od))
- (let ((info (lambda-var-arg-info arg))
- (actual (pop actual-vars)))
- (cond (info
- (case (arg-info-kind info)
- (:keyword
- (res (arg-info-key info)))
- (:rest
- (res 'rest-arg))
- (:more-context
- (res 'more-arg))
- (:optional
- (unless saw-optional
- (res 'optional-args)
- (setq saw-optional t))))
- (res (debug-location-for actual var-locs))
- (when (arg-info-supplied-p info)
- (res 'supplied-p)
- (res (debug-location-for (pop actual-vars) var-locs))))
- (t
- (res (debug-location-for actual var-locs)))))))
- (dolist (var (lambda-vars fun))
- (res (debug-location-for var var-locs)))))
+ (let ((actual-vars (lambda-vars fun))
+ (saw-optional nil))
+ (dolist (arg (optional-dispatch-arglist od))
+ (let ((info (lambda-var-arg-info arg))
+ (actual (pop actual-vars)))
+ (cond (info
+ (case (arg-info-kind info)
+ (:keyword
+ (res (arg-info-key info)))
+ (:rest
+ (res 'rest-arg))
+ (:more-context
+ (res 'more-arg))
+ (:optional
+ (unless saw-optional
+ (res 'optional-args)
+ (setq saw-optional t))))
+ (res (debug-location-for actual var-locs))
+ (when (arg-info-supplied-p info)
+ (res 'supplied-p)
+ (res (debug-location-for (pop actual-vars) var-locs))))
+ (t
+ (res (debug-location-for actual var-locs)))))))
+ (dolist (var (lambda-vars fun))
+ (res (debug-location-for var var-locs)))))
(coerce-to-smallest-eltype (res))))
(defun compute-debug-returns (fun)
(coerce-to-smallest-eltype
(mapcar (lambda (loc)
- (tn-sc-offset loc))
- (return-info-locations (tail-set-info (lambda-tail-set fun))))))
+ (tn-sc-offset loc))
+ (return-info-locations (tail-set-info (lambda-tail-set fun))))))
\f
;;;; debug functions
(defun dfun-from-fun (fun)
(declare (type clambda fun))
(let* ((2env (physenv-info (lambda-physenv fun)))
- (dispatch (lambda-optional-dispatch fun))
- (main-p (and dispatch
- (eq fun (optional-dispatch-main-entry dispatch)))))
+ (dispatch (lambda-optional-dispatch fun))
+ (main-p (and dispatch
+ (eq fun (optional-dispatch-main-entry dispatch)))))
(make-compiled-debug-fun
:name (leaf-debug-name fun)
:kind (if main-p nil (functional-kind fun))
(defun compute-1-debug-fun (fun var-locs)
(declare (type clambda fun) (type hash-table var-locs))
(let* ((dfun (dfun-from-fun fun))
- (actual-level (policy (lambda-bind fun) debug))
- (level (if #!+sb-dyncount *collect-dynamic-statistics*
- #!-sb-dyncount nil
- (max actual-level 2)
- actual-level)))
+ (actual-level (policy (lambda-bind fun) debug))
+ (level (if #!+sb-dyncount *collect-dynamic-statistics*
+ #!-sb-dyncount nil
+ (max actual-level 2)
+ actual-level)))
(cond ((zerop level))
- ((and (<= level 1)
- (let ((od (lambda-optional-dispatch fun)))
- (or (not od)
- (not (eq (optional-dispatch-main-entry od) fun)))))
- (setf (compiled-debug-fun-vars dfun)
- (compute-minimal-vars fun))
- (setf (compiled-debug-fun-arguments dfun) :minimal))
- (t
- (setf (compiled-debug-fun-vars dfun)
- (compute-vars fun level var-locs))
- (setf (compiled-debug-fun-arguments dfun)
- (compute-args fun var-locs))))
+ ((and (<= level 1)
+ (let ((od (lambda-optional-dispatch fun)))
+ (or (not od)
+ (not (eq (optional-dispatch-main-entry od) fun)))))
+ (setf (compiled-debug-fun-vars dfun)
+ (compute-minimal-vars fun))
+ (setf (compiled-debug-fun-arguments dfun) :minimal))
+ (t
+ (setf (compiled-debug-fun-vars dfun)
+ (compute-vars fun level var-locs))
+ (setf (compiled-debug-fun-arguments dfun)
+ (compute-args fun var-locs))))
(if (>= level 2)
- (multiple-value-bind (blocks tlf-num)
- (compute-debug-blocks fun var-locs)
- (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
- (setf (compiled-debug-fun-blocks dfun) blocks))
- (setf (compiled-debug-fun-tlf-number dfun) (find-tlf-number fun)))
+ (multiple-value-bind (blocks tlf-num)
+ (compute-debug-blocks fun var-locs)
+ (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
+ (setf (compiled-debug-fun-blocks dfun) blocks))
+ (setf (compiled-debug-fun-tlf-number dfun) (find-tlf-number fun)))
(if (xep-p fun)
- (setf (compiled-debug-fun-returns dfun) :standard)
- (let ((info (tail-set-info (lambda-tail-set fun))))
- (when info
- (cond ((eq (return-info-kind info) :unknown)
- (setf (compiled-debug-fun-returns dfun)
- :standard))
- ((/= level 0)
- (setf (compiled-debug-fun-returns dfun)
- (compute-debug-returns fun)))))))
+ (setf (compiled-debug-fun-returns dfun) :standard)
+ (let ((info (tail-set-info (lambda-tail-set fun))))
+ (when info
+ (cond ((eq (return-info-kind info) :unknown)
+ (setf (compiled-debug-fun-returns dfun)
+ :standard))
+ ((/= level 0)
+ (setf (compiled-debug-fun-returns dfun)
+ (compute-debug-returns fun)))))))
dfun))
\f
;;;; full component dumping
(defun compute-debug-fun-map (sorted)
(declare (list sorted))
(let* ((len (1- (* (length sorted) 2)))
- (funs-vec (make-array len)))
+ (funs-vec (make-array len)))
(do ((i -1 (+ i 2))
- (sorted sorted (cdr sorted)))
- ((= i len))
+ (sorted sorted (cdr sorted)))
+ ((= i len))
(declare (fixnum i))
(let ((dfun (car sorted)))
- (unless (minusp i)
- (setf (svref funs-vec i) (car dfun)))
- (setf (svref funs-vec (1+ i)) (cdr dfun))))
+ (unless (minusp i)
+ (setf (svref funs-vec i) (car dfun)))
+ (setf (svref funs-vec (1+ i)) (cdr dfun))))
funs-vec))
;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
(defun debug-info-for-component (component)
(declare (type component component))
(let ((dfuns nil)
- (var-locs (make-hash-table :test 'eq))
- (*byte-buffer* (make-array 10
- :element-type '(unsigned-byte 8)
- :fill-pointer 0
- :adjustable t)))
+ (var-locs (make-hash-table :test 'eq))
+ (*byte-buffer* (make-array 10
+ :element-type '(unsigned-byte 8)
+ :fill-pointer 0
+ :adjustable t)))
(dolist (lambda (component-lambdas component))
(clrhash var-locs)
(push (cons (label-position (block-label (lambda-block lambda)))
- (compute-1-debug-fun lambda var-locs))
- dfuns))
+ (compute-1-debug-fun lambda var-locs))
+ dfuns))
(let* ((sorted (sort dfuns #'< :key #'car))
- (fun-map (compute-debug-fun-map sorted)))
+ (fun-map (compute-debug-fun-map sorted)))
(make-compiled-debug-info :name (component-name component)
- :fun-map fun-map))))
+ :fun-map fun-map))))
\f
;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
;;; BITS must be evenly divisible by eight.
(multiple-value-bind (initial step done)
(ecase *backend-byte-order*
- (:little-endian (values 0 1 8))
- (:big-endian (values 7 -1 -1)))
+ (:little-endian (values 0 1 8))
+ (:big-endian (values 7 -1 -1)))
(let ((shift initial)
- (byte 0))
+ (byte 0))
(dotimes (i (length bits))
- (let ((int (aref bits i)))
- (setf byte (logior byte (ash int shift)))
- (incf shift step))
- (when (= shift done)
- (vector-push-extend byte byte-buffer)
- (setf shift initial
- byte 0)))
+ (let ((int (aref bits i)))
+ (setf byte (logior byte (ash int shift)))
+ (incf shift step))
+ (when (= shift done)
+ (vector-push-extend byte byte-buffer)
+ (setf shift initial
+ byte 0)))
(unless (= shift initial)
- (vector-push-extend byte byte-buffer))))
+ (vector-push-extend byte byte-buffer))))
(values))
(defun barf (string &rest *args*)
(unless (gethash string *ignored-errors*)
(restart-case
- (apply #'error string *args*)
+ (apply #'error string *args*)
(continue ()
- :report "Ignore this error.")
+ :report "Ignore this error.")
(ignore-all ()
- :report "Ignore this and all future occurrences of this error."
- (setf (gethash string *ignored-errors*) t))))
+ :report "Ignore this and all future occurrences of this error."
+ (setf (gethash string *ignored-errors*) t))))
(values))
(defvar *burp-action* :warn
(clrhash *seen-funs*)
(dolist (c components)
(let* ((head (component-head c))
- (tail (component-tail c)))
+ (tail (component-tail c)))
(unless (and (null (block-pred head))
- (null (block-succ tail)))
- (barf "~S is malformed." c))
+ (null (block-succ tail)))
+ (barf "~S is malformed." c))
(do ((prev nil block)
- (block head (block-next block)))
- ((null block)
- (unless (eq prev tail)
- (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
- (setf (gethash block *seen-blocks*) t)
- (unless (eq (block-prev block) prev)
- (barf "bad PREV for ~S, should be ~S" block prev))
- (unless (or (eq block tail)
- (eq (block-component block) c))
- (barf "~S is not in ~S." block c)))
+ (block head (block-next block)))
+ ((null block)
+ (unless (eq prev tail)
+ (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
+ (setf (gethash block *seen-blocks*) t)
+ (unless (eq (block-prev block) prev)
+ (barf "bad PREV for ~S, should be ~S" block prev))
+ (unless (or (eq block tail)
+ (eq (block-component block) c))
+ (barf "~S is not in ~S." block c)))
#|
(when (or (loop-blocks c) (loop-inferiors c))
- (do-blocks (block c :both)
- (setf (block-flag block) nil))
- (check-loop-consistency c nil)
- (do-blocks (block c :both)
- (unless (block-flag block)
- (barf "~S was not in any loop." block))))
+ (do-blocks (block c :both)
+ (setf (block-flag block) nil))
+ (check-loop-consistency c nil)
+ (do-blocks (block c :both)
+ (unless (block-flag block)
+ (barf "~S was not in any loop." block))))
|#
))
(dolist (c components)
(do ((block (block-next (component-head c)) (block-next block)))
- ((null (block-next block)))
+ ((null (block-next block)))
(check-block-consistency block)))
(maphash (lambda (k v)
- (declare (ignore k))
- (unless (or (constant-p v)
- (and (global-var-p v)
- (member (global-var-kind v)
- '(:global :special))))
- (barf "strange *FREE-VARS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n))
- (when (basic-var-p v)
- (dolist (n (basic-var-sets v))
- (check-node-reached n))))
- *free-vars*)
+ (declare (ignore k))
+ (unless (or (constant-p v)
+ (and (global-var-p v)
+ (member (global-var-kind v)
+ '(:global :special))))
+ (barf "strange *FREE-VARS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n))
+ (when (basic-var-p v)
+ (dolist (n (basic-var-sets v))
+ (check-node-reached n))))
+ *free-vars*)
(maphash (lambda (k v)
- (declare (ignore k))
- (unless (constant-p v)
- (barf "strange *CONSTANTS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n)))
- *constants*)
+ (declare (ignore k))
+ (unless (constant-p v)
+ (barf "strange *CONSTANTS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
+ *constants*)
(maphash (lambda (k v)
- (declare (ignore k))
- (unless (or (functional-p v)
- (and (global-var-p v)
- (eq (global-var-kind v) :global-function)))
- (barf "strange *FREE-FUNS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n)))
- *free-funs*)
+ (declare (ignore k))
+ (unless (or (functional-p v)
+ (and (global-var-p v)
+ (eq (global-var-kind v) :global-function)))
+ (barf "strange *FREE-FUNS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
+ *free-funs*)
(clrhash *seen-funs*)
(clrhash *seen-blocks*)
(values))
(let ((fun (functional-entry-fun functional)))
(check-fun-reached fun functional)
(when (functional-kind fun)
- (barf "The function for XEP ~S has kind." functional))
+ (barf "The function for XEP ~S has kind." functional))
(unless (eq (functional-entry-fun fun) functional)
- (barf "bad back-pointer in function for XEP ~S" functional))))
+ (barf "bad back-pointer in function for XEP ~S" functional))))
((:let :mv-let :assignment) ; i.e. SOMEWHAT-LETLIKE-P
(check-fun-reached (lambda-home functional) functional)
(when (functional-entry-fun functional)
(barf "The LET ~S is not in LETs for HOME." functional))
(unless (eq (functional-kind functional) :assignment)
(when (rest (leaf-refs functional))
- (barf "The LET ~S has multiple references." functional)))
+ (barf "The LET ~S has multiple references." functional)))
(when (lambda-lets functional)
(barf "LETs in a LET: ~S" functional)))
(:optional
:key (lambda (ep)
(when (promise-ready-p ep)
(force ep))))
- (eq functional (optional-dispatch-more-entry ef))
- (eq functional (optional-dispatch-main-entry ef)))
- (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
- functional ef))))
+ (eq functional (optional-dispatch-more-entry ef))
+ (eq functional (optional-dispatch-main-entry ef)))
+ (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
+ functional ef))))
(:toplevel
(unless (eq (functional-entry-fun functional) functional)
(barf "The ENTRY-FUN in ~S isn't a self-pointer." functional)))
((nil :escape :cleanup)
(let ((ef (functional-entry-fun functional)))
(when ef
- (check-fun-reached ef functional)
- (unless (eq (functional-kind ef) :external)
- (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
+ (check-fun-reached ef functional)
+ (unless (eq (functional-kind ef) :external)
+ (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
(:deleted
(return-from check-fun-stuff)))
((nil :optional :external :toplevel :escape :cleanup)
(when (lambda-p functional)
(dolist (fun (lambda-lets functional))
- (unless (eq (lambda-home fun) functional)
- (barf "The home in ~S is not ~S." fun functional))
- (check-fun-reached fun functional))
+ (unless (eq (lambda-home fun) functional)
+ (barf "The home in ~S is not ~S." fun functional))
+ (check-fun-reached fun functional))
(unless (eq (lambda-home functional) functional)
- (barf "home not self-pointer in ~S" functional)))))
+ (barf "home not self-pointer in ~S" functional)))))
(etypecase functional
(clambda
(dolist (var (lambda-vars functional))
(dolist (ref (leaf-refs var))
- (check-node-reached ref))
+ (check-node-reached ref))
(dolist (set (basic-var-sets var))
- (check-node-reached set))
+ (check-node-reached set))
(unless (eq (lambda-var-home var) functional)
- (barf "HOME in ~S should be ~S." var functional))))
+ (barf "HOME in ~S should be ~S." var functional))))
(optional-dispatch
(dolist (ep (optional-dispatch-entry-points functional))
(when (promise-ready-p ep)
(let ((more (optional-dispatch-more-entry functional)))
(when more (check-fun-reached more functional)))
(check-fun-reached (optional-dispatch-main-entry functional)
- functional))))
+ functional))))
(defun check-fun-consistency (components)
(dolist (c components)
(observe-functional new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :external)
- (let ((ef (functional-entry-fun fun)))
- (when (optional-dispatch-p ef)
- (observe-functional ef))))
+ (let ((ef (functional-entry-fun fun)))
+ (when (optional-dispatch-p ef)
+ (observe-functional ef))))
(observe-functional fun)
(dolist (let (lambda-lets fun))
- (observe-functional let))))
+ (observe-functional let))))
(dolist (c components)
(dolist (new-fun (component-new-functionals c))
(check-fun-stuff new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :deleted)
- (barf "deleted lambda ~S in Lambdas for ~S" fun c))
+ (barf "deleted lambda ~S in Lambdas for ~S" fun c))
(check-fun-stuff fun)
(dolist (let (lambda-lets fun))
- (check-fun-stuff let)))))
+ (check-fun-stuff let)))))
\f
;;;; loop consistency checking
(unless (eq (loop-superior loop) superior)
(barf "wrong superior in ~S, should be ~S" loop superior))
(when (and superior
- (/= (loop-depth loop) (1+ (loop-depth superior))))
+ (/= (loop-depth loop) (1+ (loop-depth superior))))
(barf "wrong depth in ~S" loop))
(dolist (tail (loop-tail loop))
(unless (gethash block *seen-blocks*)
(barf "unseen block ~S in loop info for ~S" block loop))
(labels ((walk (l)
- (if (eq (block-loop block) l)
- t
- (dolist (inferior (loop-inferiors l) nil)
- (when (walk inferior) (return t))))))
+ (if (eq (block-loop block) l)
+ t
+ (dolist (inferior (loop-inferiors l) nil)
+ (when (walk inferior) (return t))))))
(unless (walk loop)
(barf "~S is in loop info for ~S but not in the loop." block loop)))
(values))
(barf "bad predecessor link ~S in ~S" pred block)))
(let* ((fun (block-home-lambda block))
- (fun-deleted (eq (functional-kind fun) :deleted))
- (this-ctran (block-start block))
- (last (block-last block)))
+ (fun-deleted (eq (functional-kind fun) :deleted))
+ (this-ctran (block-start block))
+ (last (block-last block)))
(unless fun-deleted
(check-fun-reached fun block))
(when (not this-ctran)
(loop
(unless (eq (ctran-block this-ctran) block)
- (barf "BLOCK of ~S should be ~S." this-ctran block))
+ (barf "BLOCK of ~S should be ~S." this-ctran block))
(let ((node (ctran-next this-ctran)))
- (unless (node-p node)
- (barf "~S has strange NEXT." this-ctran))
- (unless (eq (node-prev node) this-ctran)
- (barf "PREV in ~S should be ~S." node this-ctran))
+ (unless (node-p node)
+ (barf "~S has strange NEXT." this-ctran))
+ (unless (eq (node-prev node) this-ctran)
+ (barf "PREV in ~S should be ~S." node this-ctran))
(when (valued-node-p node)
(binding* ((lvar (node-lvar node) :exit-if-null))
(barf "~S does not have dest." lvar))))
(check-node-reached node)
- (unless fun-deleted
- (check-node-consistency node))
-
- (let ((next (node-next node)))
- (when (and (not next) (not (eq node last)))
- (barf "~S has no NEXT." node))
- (when (eq node last) (return))
- (unless (eq (ctran-kind next) :inside-block)
- (barf "The interior ctran ~S in ~S has the wrong kind."
- next
- block))
- (unless (ctran-next next)
- (barf "~S has no NEXT." next))
- (unless (eq (ctran-use next) node)
- (barf "USE in ~S should be ~S." next node))
- (setq this-ctran next))))
+ (unless fun-deleted
+ (check-node-consistency node))
+
+ (let ((next (node-next node)))
+ (when (and (not next) (not (eq node last)))
+ (barf "~S has no NEXT." node))
+ (when (eq node last) (return))
+ (unless (eq (ctran-kind next) :inside-block)
+ (barf "The interior ctran ~S in ~S has the wrong kind."
+ next
+ block))
+ (unless (ctran-next next)
+ (barf "~S has no NEXT." next))
+ (unless (eq (ctran-use next) node)
+ (barf "USE in ~S should be ~S." next node))
+ (setq this-ctran next))))
(check-block-successors block))
(values))
(declaim (ftype (function (cblock) (values)) check-block-successors))
(defun check-block-successors (block)
(let ((last (block-last block))
- (succ (block-succ block)))
+ (succ (block-succ block)))
(let* ((comp (block-component block)))
(dolist (b succ)
- (unless (gethash b *seen-blocks*)
- (barf "unseen successor ~S in ~S" b block))
- (unless (member block (block-pred b))
- (barf "bad successor link ~S in ~S" b block))
- (unless (eq (block-component b) comp)
- (barf "The successor ~S in ~S is in a different component."
- b
- block))))
+ (unless (gethash b *seen-blocks*)
+ (barf "unseen successor ~S in ~S" b block))
+ (unless (member block (block-pred b))
+ (barf "bad successor link ~S in ~S" b block))
+ (unless (eq (block-component b) comp)
+ (barf "The successor ~S in ~S is in a different component."
+ b
+ block))))
(typecase last
(cif
(unless (proper-list-of-length-p succ 1 2)
- (barf "~S ends in an IF, but doesn't have one or two succesors."
- block))
+ (barf "~S ends in an IF, but doesn't have one or two succesors."
+ block))
(unless (member (if-consequent last) succ)
- (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
+ (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
(unless (member (if-alternative last) succ)
- (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
+ (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
(creturn
(unless (if (eq (functional-kind (return-lambda last)) :deleted)
- (null succ)
- (and (= (length succ) 1)
- (eq (first succ)
- (component-tail (block-component block)))))
- (barf "strange successors for RETURN in ~S" block)))
+ (null succ)
+ (and (= (length succ) 1)
+ (eq (first succ)
+ (component-tail (block-component block)))))
+ (barf "strange successors for RETURN in ~S" block)))
(exit
(unless (proper-list-of-length-p succ 0 1)
- (barf "EXIT node with strange number of successors: ~S" last)))
+ (barf "EXIT node with strange number of successors: ~S" last)))
(t
(unless (or (= (length succ) 1) (node-tail-p last)
- (and (block-delete-p block) (null succ)))
- (barf "~S ends in normal node, but doesn't have one successor."
- block)))))
+ (and (block-delete-p block) (null succ)))
+ (barf "~S ends in normal node, but doesn't have one successor."
+ block)))))
(values))
\f
;;;; node consistency checking
(ref
(let ((leaf (ref-leaf node)))
(when (functional-p leaf)
- (if (eq (functional-kind leaf) :toplevel-xep)
- (unless (eq (component-kind (block-component (node-block node)))
- :toplevel)
- (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
- node))
- (check-fun-reached leaf node)))))
+ (if (eq (functional-kind leaf) :toplevel-xep)
+ (unless (eq (component-kind (block-component (node-block node)))
+ :toplevel)
+ (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
+ node))
+ (check-fun-reached leaf node)))))
(basic-combination
(check-dest (basic-combination-fun node) node)
(when (and (mv-combination-p node)
(let* ((lvar (node-lvar node))
(dest (and lvar (lvar-dest lvar))))
(when (and (return-p dest)
- (eq (basic-combination-kind node) :local)
- (not (eq (lambda-tail-set (combination-lambda node))
- (lambda-tail-set (return-lambda dest)))))
- (barf "tail local call to function with different tail set:~% ~S"
- node))))
+ (eq (basic-combination-kind node) :local)
+ (not (eq (lambda-tail-set (combination-lambda node))
+ (lambda-tail-set (return-lambda dest)))))
+ (barf "tail local call to function with different tail set:~% ~S"
+ node))))
(cif
(check-dest (if-test node) node)
(unless (eq (block-last (node-block node)) node)
(barf "~S is not in ENTRIES for its home LAMBDA." node))
(dolist (exit (entry-exits node))
(unless (node-deleted exit)
- (check-node-reached node))))
+ (check-node-reached node))))
(exit
(let ((entry (exit-entry node))
- (value (exit-value node)))
+ (value (exit-value node)))
(cond (entry
- (check-node-reached entry)
- (unless (member node (entry-exits entry))
- (barf "~S is not in its ENTRY's EXITS." node))
- (when value
- (check-dest value node)))
- (t
- (when value
- (barf "~S has VALUE but no ENTRY." node)))))))
+ (check-node-reached entry)
+ (unless (member node (entry-exits entry))
+ (barf "~S is not in its ENTRY's EXITS." node))
+ (when value
+ (check-dest value node)))
+ (t
+ (when value
+ (barf "~S has VALUE but no ENTRY." node)))))))
(values))
\f
(defun check-tn-refs (refs vop write-p count more-p what)
(let ((vop-refs (vop-refs vop)))
(do ((ref refs (tn-ref-across ref))
- (num 0 (1+ num)))
- ((null ref)
- (when (< num count)
- (barf "There should be at least ~W ~A in ~S, but there are only ~W."
- count what vop num))
- (when (and (not more-p) (> num count))
- (barf "There should be ~W ~A in ~S, but are ~W."
- count what vop num)))
+ (num 0 (1+ num)))
+ ((null ref)
+ (when (< num count)
+ (barf "There should be at least ~W ~A in ~S, but there are only ~W."
+ count what vop num))
+ (when (and (not more-p) (> num count))
+ (barf "There should be ~W ~A in ~S, but are ~W."
+ count what vop num)))
(unless (eq (tn-ref-vop ref) vop)
- (barf "VOP is ~S isn't ~S." ref vop))
+ (barf "VOP is ~S isn't ~S." ref vop))
(unless (eq (tn-ref-write-p ref) write-p)
- (barf "The WRITE-P in ~S isn't ~S." vop write-p))
+ (barf "The WRITE-P in ~S isn't ~S." vop write-p))
(unless (find-in #'tn-ref-next-ref ref vop-refs)
- (barf "~S not found in REFS for ~S" ref vop))
+ (barf "~S not found in REFS for ~S" ref vop))
(unless (find-in #'tn-ref-next ref
- (if (tn-ref-write-p ref)
- (tn-writes (tn-ref-tn ref))
- (tn-reads (tn-ref-tn ref))))
- (barf "~S not found in reads/writes for its TN" ref))
+ (if (tn-ref-write-p ref)
+ (tn-writes (tn-ref-tn ref))
+ (tn-reads (tn-ref-tn ref))))
+ (barf "~S not found in reads/writes for its TN" ref))
(let ((target (tn-ref-target ref)))
- (when target
- (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
- (barf "The target for ~S isn't complementary WRITE-P." ref))
- (unless (find-in #'tn-ref-next-ref target vop-refs)
- (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
+ (when target
+ (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
+ (barf "The target for ~S isn't complementary WRITE-P." ref))
+ (unless (find-in #'tn-ref-next-ref target vop-refs)
+ (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
;;; Verify the sanity of the VOP-REFS slot in VOP. This involves checking
;;; that each referenced TN appears as an argument, result or temp, and also
(barf "stray ref that isn't a READ: ~S" ref))
(t
(let* ((tn (tn-ref-tn ref))
- (temp (find-in #'tn-ref-across tn (vop-temps vop)
- :key #'tn-ref-tn)))
- (unless temp
- (barf "stray ref with no corresponding temp write: ~S" ref))
- (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
- (barf "Read is after write for temp ~S in refs of ~S."
- tn vop))))))
+ (temp (find-in #'tn-ref-across tn (vop-temps vop)
+ :key #'tn-ref-tn)))
+ (unless temp
+ (barf "stray ref with no corresponding temp write: ~S" ref))
+ (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
+ (barf "Read is after write for temp ~S in refs of ~S."
+ tn vop))))))
(values))
;;; Check the basic sanity of the VOP linkage, then call some other
(defun check-ir2-block-consistency (2block)
(declare (type ir2-block 2block))
(do ((vop (ir2-block-start-vop 2block)
- (vop-next vop))
+ (vop-next vop))
(prev nil vop))
((null vop)
(unless (eq prev (ir2-block-last-vop 2block))
- (barf "The last VOP in ~S should be ~S." 2block prev)))
+ (barf "The last VOP in ~S should be ~S." 2block prev)))
(unless (eq (vop-prev vop) prev)
(barf "PREV in ~S should be ~S." vop prev))
(check-vop-refs vop)
(let* ((info (vop-info vop))
- (atypes (template-arg-types info))
- (rtypes (template-result-types info)))
+ (atypes (template-arg-types info))
+ (rtypes (template-result-types info)))
(check-tn-refs (vop-args vop) vop nil
- (count-if-not (lambda (x)
- (and (consp x)
- (eq (car x) :constant)))
- atypes)
- (template-more-args-type info) "args")
+ (count-if-not (lambda (x)
+ (and (consp x)
+ (eq (car x) :constant)))
+ atypes)
+ (template-more-args-type info) "args")
(check-tn-refs (vop-results vop) vop t
- (if (eq rtypes :conditional) 0 (length rtypes))
- (template-more-results-type info) "results")
+ (if (eq rtypes :conditional) 0 (length rtypes))
+ (template-more-results-type info) "results")
(check-tn-refs (vop-temps vop) vop t 0 t "temps")
(unless (= (length (vop-codegen-info vop))
- (template-info-arg-count info))
- (barf "wrong number of codegen info args in ~S" vop))))
+ (template-info-arg-count info))
+ (barf "wrong number of codegen info args in ~S" vop))))
(values))
;;; Check stuff about the IR2 representation of COMPONENT. This assumes the
(defun pre-pack-tn-stats (component &optional (stream *standard-output*))
(declare (type component component))
(let ((wired 0)
- (global 0)
- (local 0)
- (confs 0)
- (unused 0)
- (const 0)
- (temps 0)
- (environment 0)
- (comp 0))
+ (global 0)
+ (local 0)
+ (confs 0)
+ (unused 0)
+ (const 0)
+ (temps 0)
+ (environment 0)
+ (comp 0))
(do-packed-tns (tn component)
(let ((reads (tn-reads tn))
- (writes (tn-writes tn)))
- (when (and reads writes
- (not (tn-ref-next reads)) (not (tn-ref-next writes))
- (eq (tn-ref-vop reads) (tn-ref-vop writes)))
- (incf temps)))
+ (writes (tn-writes tn)))
+ (when (and reads writes
+ (not (tn-ref-next reads)) (not (tn-ref-next writes))
+ (eq (tn-ref-vop reads) (tn-ref-vop writes)))
+ (incf temps)))
(when (tn-offset tn)
- (incf wired))
+ (incf wired))
(unless (or (tn-reads tn) (tn-writes tn))
- (incf unused))
+ (incf unused))
(cond ((eq (tn-kind tn) :component)
- (incf comp))
- ((tn-global-conflicts tn)
- (case (tn-kind tn)
- ((:environment :debug-environment) (incf environment))
- (t (incf global)))
- (do ((conf (tn-global-conflicts tn)
- (global-conflicts-next-tnwise conf)))
- ((null conf))
- (incf confs)))
- (t
- (incf local))))
+ (incf comp))
+ ((tn-global-conflicts tn)
+ (case (tn-kind tn)
+ ((:environment :debug-environment) (incf environment))
+ (t (incf global)))
+ (do ((conf (tn-global-conflicts tn)
+ (global-conflicts-next-tnwise conf)))
+ ((null conf))
+ (incf confs)))
+ (t
+ (incf local))))
(do ((tn (ir2-component-constant-tns (component-info component))
- (tn-next tn)))
- ((null tn))
+ (tn-next tn)))
+ ((null tn))
(incf const))
(format stream
;;; for the validity of the usage.
(defun check-more-tn-entry (tn block)
(let* ((vop (ir2-block-start-vop block))
- (info (vop-info vop)))
+ (info (vop-info vop)))
(macrolet ((frob (more-p ops)
- `(and (,more-p info)
- (find-in #'tn-ref-across tn (,ops vop)
- :key #'tn-ref-tn))))
+ `(and (,more-p info)
+ (find-in #'tn-ref-across tn (,ops vop)
+ :key #'tn-ref-tn))))
(unless (and (eq vop (ir2-block-last-vop block))
- (or (frob template-more-args-type vop-args)
- (frob template-more-results-type vop-results)))
- (barf "strange :MORE LTN entry for ~S in ~S" tn block))))
+ (or (frob template-more-args-type vop-args)
+ (frob template-more-results-type vop-results)))
+ (barf "strange :MORE LTN entry for ~S in ~S" tn block))))
(values))
(defun check-tn-conflicts (component)
(do-packed-tns (tn component)
(unless (or (not (eq (tn-kind tn) :normal))
- (tn-reads tn)
- (tn-writes tn))
+ (tn-reads tn)
+ (tn-writes tn))
(barf "no references to ~S" tn))
(unless (tn-sc tn) (barf "~S has no SC." tn))
(let ((conf (tn-global-conflicts tn))
- (kind (tn-kind tn)))
+ (kind (tn-kind tn)))
(cond
((eq kind :component)
- (unless (member tn (ir2-component-component-tns
- (component-info component)))
- (barf "~S not in COMPONENT-TNs for ~S" tn component)))
+ (unless (member tn (ir2-component-component-tns
+ (component-info component)))
+ (barf "~S not in COMPONENT-TNs for ~S" tn component)))
(conf
- (do ((conf conf (global-conflicts-next-tnwise conf))
- (prev nil conf))
- ((null conf))
- (unless (eq (global-conflicts-tn conf) tn)
- (barf "TN in ~S should be ~S." conf tn))
-
- (unless (eq (global-conflicts-kind conf) :live)
- (let* ((block (global-conflicts-block conf))
- (ltn (svref (ir2-block-local-tns block)
- (global-conflicts-number conf))))
- (cond ((eq ltn tn))
- ((eq ltn :more) (check-more-tn-entry tn block))
- (t
- (barf "~S wrong in LTN map for ~S" conf tn)))))
-
- (when prev
- (unless (> (ir2-block-number (global-conflicts-block conf))
- (ir2-block-number (global-conflicts-block prev)))
- (barf "~s and ~s out of order" prev conf)))))
+ (do ((conf conf (global-conflicts-next-tnwise conf))
+ (prev nil conf))
+ ((null conf))
+ (unless (eq (global-conflicts-tn conf) tn)
+ (barf "TN in ~S should be ~S." conf tn))
+
+ (unless (eq (global-conflicts-kind conf) :live)
+ (let* ((block (global-conflicts-block conf))
+ (ltn (svref (ir2-block-local-tns block)
+ (global-conflicts-number conf))))
+ (cond ((eq ltn tn))
+ ((eq ltn :more) (check-more-tn-entry tn block))
+ (t
+ (barf "~S wrong in LTN map for ~S" conf tn)))))
+
+ (when prev
+ (unless (> (ir2-block-number (global-conflicts-block conf))
+ (ir2-block-number (global-conflicts-block prev)))
+ (barf "~s and ~s out of order" prev conf)))))
((member (tn-kind tn) '(:constant :specified-save)))
(t
- (let ((local (tn-local tn)))
- (unless local
- (barf "~S has no global conflicts, but isn't local either." tn))
- (unless (eq (svref (ir2-block-local-tns local)
- (tn-local-number tn))
- tn)
- (barf "~S wrong in LTN map" tn))
- (do ((ref (tn-reads tn) (tn-ref-next ref)))
- ((null ref))
- (unless (eq (vop-block (tn-ref-vop ref)) local)
- (barf "~S has references in blocks other than its LOCAL block."
- tn)))
- (do ((ref (tn-writes tn) (tn-ref-next ref)))
- ((null ref))
- (unless (eq (vop-block (tn-ref-vop ref)) local)
- (barf "~S has references in blocks other than its LOCAL block."
- tn))))))))
+ (let ((local (tn-local tn)))
+ (unless local
+ (barf "~S has no global conflicts, but isn't local either." tn))
+ (unless (eq (svref (ir2-block-local-tns local)
+ (tn-local-number tn))
+ tn)
+ (barf "~S wrong in LTN map" tn))
+ (do ((ref (tn-reads tn) (tn-ref-next ref)))
+ ((null ref))
+ (unless (eq (vop-block (tn-ref-vop ref)) local)
+ (barf "~S has references in blocks other than its LOCAL block."
+ tn)))
+ (do ((ref (tn-writes tn) (tn-ref-next ref)))
+ ((null ref))
+ (unless (eq (vop-block (tn-ref-vop ref)) local)
+ (barf "~S has references in blocks other than its LOCAL block."
+ tn))))))))
(values))
(defun check-block-conflicts (component)
(do-ir2-blocks (block component)
(do ((conf (ir2-block-global-tns block)
- (global-conflicts-next-blockwise conf))
- (prev nil conf))
- ((null conf))
+ (global-conflicts-next-blockwise conf))
+ (prev nil conf))
+ ((null conf))
(when prev
- (unless (> (tn-number (global-conflicts-tn conf))
- (tn-number (global-conflicts-tn prev)))
- (barf "~S and ~S out of order in ~S" prev conf block)))
+ (unless (> (tn-number (global-conflicts-tn conf))
+ (tn-number (global-conflicts-tn prev)))
+ (barf "~S and ~S out of order in ~S" prev conf block)))
(unless (find-in #'global-conflicts-next-tnwise
- conf
- (tn-global-conflicts
- (global-conflicts-tn conf)))
- (barf "~S missing from global conflicts of its TN" conf)))
+ conf
+ (tn-global-conflicts
+ (global-conflicts-tn conf)))
+ (barf "~S missing from global conflicts of its TN" conf)))
(let ((map (ir2-block-local-tns block)))
(dotimes (i (ir2-block-local-tn-count block))
- (let ((tn (svref map i)))
- (unless (or (eq tn :more)
- (null tn)
- (tn-global-conflicts tn)
- (eq (tn-local tn) block))
- (barf "strange TN ~S in LTN map for ~S" tn block)))))))
+ (let ((tn (svref map i)))
+ (unless (or (eq tn :more)
+ (null tn)
+ (tn-global-conflicts tn)
+ (eq (tn-local tn) block))
+ (barf "strange TN ~S in LTN map for ~S" tn block)))))))
;;; All TNs live at the beginning of an environment must be passing
;;; locations associated with that environment. We make an exception
(defun check-environment-lifetimes (component)
(dolist (fun (component-lambdas component))
(let* ((env (lambda-physenv fun))
- (2env (physenv-info env))
- (vars (lambda-vars fun))
- (closure (ir2-physenv-closure 2env))
- (pc (ir2-physenv-return-pc-pass 2env))
- (fp (ir2-physenv-old-fp 2env))
- (2block (block-info (lambda-block (physenv-lambda env)))))
+ (2env (physenv-info env))
+ (vars (lambda-vars fun))
+ (closure (ir2-physenv-closure 2env))
+ (pc (ir2-physenv-return-pc-pass 2env))
+ (fp (ir2-physenv-old-fp 2env))
+ (2block (block-info (lambda-block (physenv-lambda env)))))
(do ((conf (ir2-block-global-tns 2block)
- (global-conflicts-next-blockwise conf)))
- ((null conf))
- (let ((tn (global-conflicts-tn conf)))
- (unless (or (eq (global-conflicts-kind conf) :write)
- (eq tn pc)
- (eq tn fp)
- (and (xep-p fun) (tn-offset tn))
- (member (tn-kind tn) '(:environment :debug-environment))
- (member tn vars :key #'leaf-info)
- (member tn closure :key #'cdr))
- (barf "strange TN live at head of ~S: ~S" env tn))))))
+ (global-conflicts-next-blockwise conf)))
+ ((null conf))
+ (let ((tn (global-conflicts-tn conf)))
+ (unless (or (eq (global-conflicts-kind conf) :write)
+ (eq tn pc)
+ (eq tn fp)
+ (and (xep-p fun) (tn-offset tn))
+ (member (tn-kind tn) '(:environment :debug-environment))
+ (member tn vars :key #'leaf-info)
+ (member tn closure :key #'cdr))
+ (barf "strange TN live at head of ~S: ~S" env tn))))))
(values))
;;; Check for some basic sanity in the TN conflict data structures,
(defun check-pack-consistency (component)
(flet ((check (scs ops)
- (do ((scs scs (cdr scs))
- (op ops (tn-ref-across op)))
- ((null scs))
- (let ((load-tn (tn-ref-load-tn op)))
- (unless (eq (svref (car scs)
- (sc-number
- (tn-sc
- (or load-tn (tn-ref-tn op)))))
- t)
- (barf "operand restriction not satisfied: ~S" op))))))
+ (do ((scs scs (cdr scs))
+ (op ops (tn-ref-across op)))
+ ((null scs))
+ (let ((load-tn (tn-ref-load-tn op)))
+ (unless (eq (svref (car scs)
+ (sc-number
+ (tn-sc
+ (or load-tn (tn-ref-tn op)))))
+ t)
+ (barf "operand restriction not satisfied: ~S" op))))))
(do-ir2-blocks (block component)
(do ((vop (ir2-block-last-vop block) (vop-prev vop)))
- ((null vop))
- (let ((info (vop-info vop)))
- (check (vop-info-result-load-scs info) (vop-results vop))
- (check (vop-info-arg-load-scs info) (vop-args vop))))))
+ ((null vop))
+ (let ((info (vop-info vop)))
+ (check (vop-info-result-load-scs info) (vop-results vop))
+ (check (vop-info-arg-load-scs info) (vop-args vop))))))
(values))
\f
;;;; data structure dumping routines
;;; there will be a tendency for them to grow without bound and
;;; keep garbage from being collected.
(macrolet ((def (counter vto vfrom fto ffrom)
- `(progn
- (declaim (type hash-table ,vto ,vfrom))
- (defvar ,vto (make-hash-table :test 'eq))
- (defvar ,vfrom (make-hash-table :test 'eql))
- (declaim (type fixnum ,counter))
- (defvar ,counter 0)
-
- (defun ,fto (x)
- (or (gethash x ,vto)
- (let ((num (incf ,counter)))
- (setf (gethash num ,vfrom) x)
- (setf (gethash x ,vto) num))))
-
- (defun ,ffrom (num)
- (values (gethash num ,vfrom))))))
+ `(progn
+ (declaim (type hash-table ,vto ,vfrom))
+ (defvar ,vto (make-hash-table :test 'eq))
+ (defvar ,vfrom (make-hash-table :test 'eql))
+ (declaim (type fixnum ,counter))
+ (defvar ,counter 0)
+
+ (defun ,fto (x)
+ (or (gethash x ,vto)
+ (let ((num (incf ,counter)))
+ (setf (gethash num ,vfrom) x)
+ (setf (gethash x ,vto) num))))
+
+ (defun ,ffrom (num)
+ (values (gethash num ,vfrom))))))
(def *continuation-number* *continuation-numbers* *number-continuations*
cont-num num-cont)
(def *tn-id* *tn-ids* *id-tns* tn-id id-tn)
(declare (type tn tn))
(let ((leaf (tn-leaf tn)))
(cond (leaf
- (print-leaf leaf stream)
- (format stream "!~D" (tn-id tn)))
- (t
- (format stream "t~D" (tn-id tn))))
+ (print-leaf leaf stream)
+ (format stream "!~D" (tn-id tn)))
+ (t
+ (format stream "t~D" (tn-id tn))))
(when (and (tn-sc tn) (tn-offset tn))
(format stream "[~A]" (location-print-name tn)))))
(declare (type (or tn-ref null) refs))
(pprint-logical-block (*standard-output* nil)
(do ((ref refs (tn-ref-across ref)))
- ((null ref))
+ ((null ref))
(let ((tn (tn-ref-tn ref))
- (ltn (tn-ref-load-tn ref)))
- (cond ((not ltn)
- (print-tn-guts tn))
- (t
- (print-tn-guts tn)
- (princ (if (tn-ref-write-p ref) #\< #\>))
- (print-tn-guts ltn)))
- (princ #\space)
- (pprint-newline :fill)))))
+ (ltn (tn-ref-load-tn ref)))
+ (cond ((not ltn)
+ (print-tn-guts tn))
+ (t
+ (print-tn-guts tn)
+ (princ (if (tn-ref-write-p ref) #\< #\>))
+ (print-tn-guts ltn)))
+ (princ #\space)
+ (pprint-newline :fill)))))
;;; Print the VOP, putting args, info and results on separate lines, if
;;; necessary.
(pprint-newline :linear)
(when (vop-codegen-info vop)
(princ (with-output-to-string (stream)
- (let ((*print-level* 1)
- (*print-length* 3))
- (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
+ (let ((*print-level* 1)
+ (*print-length* 3))
+ (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
(pprint-newline :linear))
(when (vop-results vop)
(princ "=> ")
(let ((2block (block-info block)))
(print-ir2-block 2block)
(do ((b (ir2-block-next 2block) (ir2-block-next b)))
- ((not (eq (ir2-block-block b) block)))
+ ((not (eq (ir2-block-block b) block)))
(print-ir2-block b)))
(values))
(do-blocks (block (block-component block) :both)
(setf (block-flag block) nil))
(labels ((walk (block)
- (unless (block-flag block)
- (setf (block-flag block) t)
- (when (block-start block)
- (print-nodes block))
- (dolist (block (block-succ block))
- (walk block)))))
+ (unless (block-flag block)
+ (setf (block-flag block) t)
+ (when (block-start block)
+ (print-nodes block))
+ (dolist (block (block-succ block))
+ (walk block)))))
(walk block))
(values))
(do-blocks (block (block-component (block-or-lose thing)))
(handler-case (print-nodes block)
(error (condition)
- (format t "~&~A...~%" condition))))
+ (format t "~&~A...~%" condition))))
(values))
(defvar *list-conflicts-table* (make-hash-table :test 'eq))
(defun add-always-live-tns (block tn)
(declare (type ir2-block block) (type tn tn))
(do ((conf (ir2-block-global-tns block)
- (global-conflicts-next-blockwise conf)))
+ (global-conflicts-next-blockwise conf)))
((null conf))
(when (eq (global-conflicts-kind conf) :live)
(let ((btn (global-conflicts-tn conf)))
- (unless (eq btn tn)
- (setf (gethash btn *list-conflicts-table*) t)))))
+ (unless (eq btn tn)
+ (setf (gethash btn *list-conflicts-table*) t)))))
(values))
;;; Add all local TNs in BLOCK to the conflicts.
(defun listify-conflicts-table ()
(collect ((res))
(maphash (lambda (k v)
- (declare (ignore v))
- (when k
- (res k)))
- *list-conflicts-table*)
+ (declare (ignore v))
+ (when k
+ (res k)))
+ *list-conflicts-table*)
(clrhash *list-conflicts-table*)
(res)))
(aver (member (tn-kind tn) '(:normal :environment :debug-environment)))
(let ((confs (tn-global-conflicts tn)))
(cond (confs
- (clrhash *list-conflicts-table*)
- (do ((conf confs (global-conflicts-next-tnwise conf)))
- ((null conf))
+ (clrhash *list-conflicts-table*)
+ (do ((conf confs (global-conflicts-next-tnwise conf)))
+ ((null conf))
(format t "~&#<block ~D kind ~S>~%"
(block-number (ir2-block-block (global-conflicts-block
- conf)))
+ conf)))
(global-conflicts-kind conf))
- (let ((block (global-conflicts-block conf)))
- (add-always-live-tns block tn)
- (if (eq (global-conflicts-kind conf) :live)
- (add-all-local-tns block)
- (let ((bconf (global-conflicts-conflicts conf))
- (ltns (ir2-block-local-tns block)))
- (dotimes (i (ir2-block-local-tn-count block))
- (when (/= (sbit bconf i) 0)
- (setf (gethash (svref ltns i) *list-conflicts-table*)
- t)))))))
- (listify-conflicts-table))
- (t
- (let* ((block (tn-local tn))
- (ltns (ir2-block-local-tns block))
- (confs (tn-local-conflicts tn)))
- (collect ((res))
- (dotimes (i (ir2-block-local-tn-count block))
- (when (/= (sbit confs i) 0)
- (let ((tn (svref ltns i)))
- (when (and tn (not (eq tn :more))
- (not (tn-global-conflicts tn)))
- (res tn)))))
- (do ((gtn (ir2-block-global-tns block)
- (global-conflicts-next-blockwise gtn)))
- ((null gtn))
- (when (or (eq (global-conflicts-kind gtn) :live)
- (/= (sbit confs (global-conflicts-number gtn)) 0))
- (res (global-conflicts-tn gtn))))
- (res)))))))
+ (let ((block (global-conflicts-block conf)))
+ (add-always-live-tns block tn)
+ (if (eq (global-conflicts-kind conf) :live)
+ (add-all-local-tns block)
+ (let ((bconf (global-conflicts-conflicts conf))
+ (ltns (ir2-block-local-tns block)))
+ (dotimes (i (ir2-block-local-tn-count block))
+ (when (/= (sbit bconf i) 0)
+ (setf (gethash (svref ltns i) *list-conflicts-table*)
+ t)))))))
+ (listify-conflicts-table))
+ (t
+ (let* ((block (tn-local tn))
+ (ltns (ir2-block-local-tns block))
+ (confs (tn-local-conflicts tn)))
+ (collect ((res))
+ (dotimes (i (ir2-block-local-tn-count block))
+ (when (/= (sbit confs i) 0)
+ (let ((tn (svref ltns i)))
+ (when (and tn (not (eq tn :more))
+ (not (tn-global-conflicts tn)))
+ (res tn)))))
+ (do ((gtn (ir2-block-global-tns block)
+ (global-conflicts-next-blockwise gtn)))
+ ((null gtn))
+ (when (or (eq (global-conflicts-kind gtn) :live)
+ (/= (sbit confs (global-conflicts-number gtn)) 0))
+ (res (global-conflicts-tn gtn))))
+ (res)))))))
(defun nth-vop (thing n)
#!+sb-doc
"Return the Nth VOP in the IR2-BLOCK pointed to by THING."
(let ((block (block-info (block-or-lose thing))))
(do ((i 0 (1+ i))
- (vop (ir2-block-start-vop block) (vop-next vop)))
- ((= i n) vop))))
+ (vop (ir2-block-start-vop block) (vop-next vop)))
+ ((= i n) vop))))
(when (looks-like-name-of-special-var-p name)
(style-warn "defining ~S as a constant, even though the name follows~@
the usual naming convention (names like *FOO*) for special variables"
- name))
+ name))
(let ((kind (info :variable :kind name)))
(case kind
(:constant
;; something like the DEFCONSTANT-EQX macro used in SBCL (which
;; is occasionally more appropriate). -- WHN 2001-12-21
(unless (eql value
- (info :variable :constant-value name))
- (multiple-value-bind (ignore aborted)
- (with-simple-restart (abort "Keep the old value.")
- (cerror "Go ahead and change the value."
- 'defconstant-uneql
- :name name
- :old-value (info :variable :constant-value name)
- :new-value value))
- (declare (ignore ignore))
- (when aborted
- (return-from sb!c::%defconstant name)))))
+ (info :variable :constant-value name))
+ (multiple-value-bind (ignore aborted)
+ (with-simple-restart (abort "Keep the old value.")
+ (cerror "Go ahead and change the value."
+ 'defconstant-uneql
+ :name name
+ :old-value (info :variable :constant-value name)
+ :new-value value))
+ (declare (ignore ignore))
+ (when aborted
+ (return-from sb!c::%defconstant name)))))
(:global
;; (This is OK -- undefined variables are of this kind. So we
;; don't warn or error or anything, just fall through.)
;; CL:FOO. It would be good to unscrew the
;; cross-compilation package hacks so that that
;; translation doesn't happen. Perhaps:
- ;; * Replace SB-XC with SB-CL. SB-CL exports all the
+ ;; * Replace SB-XC with SB-CL. SB-CL exports all the
;; symbols which ANSI requires to be exported from CL.
;; * Make a nickname SB!CL which behaves like SB!XC.
;; * Go through the loaded-on-the-host code making
;; every target definition be in SB-CL. E.g.
;; DEFMACRO-MUNDANELY DEFCONSTANT becomes
;; DEFMACRO-MUNDANELY SB!CL:DEFCONSTANT.
- ;; * Make IN-TARGET-COMPILATION-MODE do
+ ;; * Make IN-TARGET-COMPILATION-MODE do
;; UNUSE-PACKAGE CL and USE-PACKAGE SB-CL in each
;; of the target packages (then undo it on exit).
;; * Make the cross-compiler's implementation of
(eval `(defconstant ,name ',value))))
(setf (info :variable :kind name) :constant
- (info :variable :constant-value name) value)
+ (info :variable :constant-value name) value)
name)
(error "type name not a symbol: ~S" name))
(with-unique-names (whole)
(multiple-value-bind (body local-decs doc)
- (parse-defmacro arglist whole body name 'deftype :default-default ''*)
+ (parse-defmacro arglist whole body name 'deftype :default-default ''*)
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (%compiler-deftype ',name
- (lambda (,whole)
- ,@local-decs
- ,body)
- ,@(when doc `(,doc)))))))
+ (%compiler-deftype ',name
+ (lambda (,whole)
+ ,@local-decs
+ ,body)
+ ,@(when doc `(,doc)))))))
(setf (component-reanalyze component) nil)
(let ((head (component-head component)))
(do ()
- ((dolist (ep (block-succ head) t)
- (unless (or (block-flag ep) (block-delete-p ep))
- (find-dfo-aux ep head component)
- (return nil))))))
+ ((dolist (ep (block-succ head) t)
+ (unless (or (block-flag ep) (block-delete-p ep))
+ (find-dfo-aux ep head component)
+ (return nil))))))
(let ((num 0))
(declare (fixnum num))
(do-blocks-backwards (block component :both)
(if (block-flag block)
- (setf (block-number block) (incf num))
- (delete-block-lazily block)))
+ (setf (block-number block) (incf num))
+ (delete-block-lazily block)))
(clean-component component (component-head component)))
(values))
(defun join-components (new old)
(aver (eq (component-kind new) (component-kind old)))
(let ((old-head (component-head old))
- (old-tail (component-tail old))
- (head (component-head new))
- (tail (component-tail new)))
+ (old-tail (component-tail old))
+ (head (component-head new))
+ (tail (component-tail new)))
(do-blocks (block old)
(setf (block-flag block) nil)
(setf (block-component block) new))
(let ((old-next (block-next old-head))
- (old-last (block-prev old-tail))
- (next (block-next head)))
+ (old-last (block-prev old-tail))
+ (next (block-next head)))
(unless (eq old-next old-tail)
- (setf (block-next head) old-next)
- (setf (block-prev old-next) head)
+ (setf (block-next head) old-next)
+ (setf (block-prev old-next) head)
- (setf (block-prev next) old-last)
- (setf (block-next old-last) next))
+ (setf (block-prev next) old-last)
+ (setf (block-next old-last) next))
(setf (block-next old-head) old-tail)
(setf (block-prev old-tail) old-head))
(setf (component-lambdas new)
- (nconc (component-lambdas old) (component-lambdas new)))
+ (nconc (component-lambdas old) (component-lambdas new)))
(setf (component-lambdas old) nil)
(setf (component-new-functionals new)
- (nconc (component-new-functionals old)
- (component-new-functionals new)))
+ (nconc (component-new-functionals old)
+ (component-new-functionals new)))
(setf (component-new-functionals old) nil)
(dolist (xp (block-pred old-tail))
(declare (type cblock block) (type component component))
(let ((home-lambda (block-home-lambda block)))
(if (eq (functional-kind home-lambda) :deleted)
- component
- (let ((home-component (lambda-component home-lambda)))
- (cond ((eq (component-kind home-component) :initial)
- (dfo-scavenge-dependency-graph home-lambda component))
- ((eq home-component component)
- component)
- (t
- (join-components home-component component)
- home-component))))))
+ component
+ (let ((home-component (lambda-component home-lambda)))
+ (cond ((eq (component-kind home-component) :initial)
+ (dfo-scavenge-dependency-graph home-lambda component))
+ ((eq home-component component)
+ component)
+ (t
+ (join-components home-component component)
+ home-component))))))
;;; This is somewhat similar to FIND-DFO-AUX, except that it merges
;;; the current component with any strange component, rather than the
(let ((this (block-component block)))
(cond
((not (or (eq this component)
- (eq (component-kind this) :initial)))
+ (eq (component-kind this) :initial)))
(join-components this component)
this)
((block-flag block) component)
(t
(setf (block-flag block) t)
(let ((current (scavenge-home-dependency-graph block component)))
- (dolist (succ (block-succ block))
- (setq current (find-initial-dfo-aux succ current)))
- (remove-from-dfo block)
- (add-to-dfo block (component-head current))
- current)))))
+ (dolist (succ (block-succ block))
+ (setq current (find-initial-dfo-aux succ current)))
+ (remove-from-dfo block)
+ (add-to-dfo block (component-head current))
+ current)))))
;;; Return a list of all the home lambdas that reference FUN (may
;;; contain duplications).
(collect ((res))
(dolist (ref (leaf-refs fun))
(let* ((home (node-home-lambda ref))
- (home-kind (functional-kind home))
- (home-externally-visible-p
- (or (eq home-kind :toplevel)
- (functional-has-external-references-p home))))
- (unless (or (and home-externally-visible-p
- (eq (functional-kind fun) :external))
- (eq home-kind :deleted))
- (res home))))
+ (home-kind (functional-kind home))
+ (home-externally-visible-p
+ (or (eq home-kind :toplevel)
+ (functional-has-external-references-p home))))
+ (unless (or (and home-externally-visible-p
+ (eq (functional-kind fun) :external))
+ (eq home-kind :deleted))
+ (res home))))
(res)))
;;; If CLAMBDA is already in COMPONENT, just return that
(declare (type clambda clambda) (type component component))
(assert (not (eql (lambda-kind clambda) :deleted)))
(let* ((bind-block (node-block (lambda-bind clambda)))
- (old-lambda-component (block-component bind-block))
- (return (lambda-return clambda)))
+ (old-lambda-component (block-component bind-block))
+ (return (lambda-return clambda)))
(cond
((eq old-lambda-component component)
component)
(t
(push clambda (component-lambdas component))
(setf (component-lambdas old-lambda-component)
- (delete clambda (component-lambdas old-lambda-component)))
+ (delete clambda (component-lambdas old-lambda-component)))
(link-blocks (component-head component) bind-block)
(unlink-blocks (component-head old-lambda-component) bind-block)
(when return
- (let ((return-block (node-block return)))
- (link-blocks return-block (component-tail component))
- (unlink-blocks return-block (component-tail old-lambda-component))))
+ (let ((return-block (node-block return)))
+ (link-blocks return-block (component-tail component))
+ (unlink-blocks return-block (component-tail old-lambda-component))))
(let ((res (find-initial-dfo-aux bind-block component)))
- (declare (type component res))
- ;; Scavenge related lambdas.
- (labels ((scavenge-lambda (clambda)
- (setf res
- (dfo-scavenge-dependency-graph (lambda-home clambda)
- res)))
- (scavenge-possibly-deleted-lambda (clambda)
- (unless (eql (lambda-kind clambda) :deleted)
- (scavenge-lambda clambda)))
- ;; Scavenge call relationship.
- (scavenge-call (called-lambda)
- (scavenge-lambda called-lambda))
- ;; Scavenge closure over a variable: if CLAMBDA
- ;; refers to a variable whose home lambda is not
- ;; CLAMBDA, then the home lambda should be in the
- ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
- ;; CL, didn't do this, leading to the occasional
- ;; failure when physenv analysis, which is local to
- ;; each component, would bogusly conclude that a
- ;; closed-over variable was unused and thus delete
- ;; it. See e.g. cmucl-imp 2001-11-29.)
- (scavenge-closure-var (var)
- (unless (null (lambda-var-refs var)) ; unless var deleted
- (let ((var-home-home (lambda-home (lambda-var-home var))))
- (scavenge-possibly-deleted-lambda var-home-home))))
- ;; Scavenge closure over an entry for nonlocal exit.
- ;; This is basically parallel to closure over a
- ;; variable above.
- (scavenge-entry (entry)
- (declare (type entry entry))
- (let ((entry-home (node-home-lambda entry)))
- (scavenge-possibly-deleted-lambda entry-home))))
- (dolist (cc (lambda-calls-or-closes clambda))
- (etypecase cc
- (clambda (scavenge-call cc))
- (lambda-var (scavenge-closure-var cc))
- (entry (scavenge-entry cc))))
- (when (eq (lambda-kind clambda) :external)
- (mapc #'scavenge-call (find-reference-funs clambda))))
- ;; Voila.
- res)))))
+ (declare (type component res))
+ ;; Scavenge related lambdas.
+ (labels ((scavenge-lambda (clambda)
+ (setf res
+ (dfo-scavenge-dependency-graph (lambda-home clambda)
+ res)))
+ (scavenge-possibly-deleted-lambda (clambda)
+ (unless (eql (lambda-kind clambda) :deleted)
+ (scavenge-lambda clambda)))
+ ;; Scavenge call relationship.
+ (scavenge-call (called-lambda)
+ (scavenge-lambda called-lambda))
+ ;; Scavenge closure over a variable: if CLAMBDA
+ ;; refers to a variable whose home lambda is not
+ ;; CLAMBDA, then the home lambda should be in the
+ ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
+ ;; CL, didn't do this, leading to the occasional
+ ;; failure when physenv analysis, which is local to
+ ;; each component, would bogusly conclude that a
+ ;; closed-over variable was unused and thus delete
+ ;; it. See e.g. cmucl-imp 2001-11-29.)
+ (scavenge-closure-var (var)
+ (unless (null (lambda-var-refs var)) ; unless var deleted
+ (let ((var-home-home (lambda-home (lambda-var-home var))))
+ (scavenge-possibly-deleted-lambda var-home-home))))
+ ;; Scavenge closure over an entry for nonlocal exit.
+ ;; This is basically parallel to closure over a
+ ;; variable above.
+ (scavenge-entry (entry)
+ (declare (type entry entry))
+ (let ((entry-home (node-home-lambda entry)))
+ (scavenge-possibly-deleted-lambda entry-home))))
+ (dolist (cc (lambda-calls-or-closes clambda))
+ (etypecase cc
+ (clambda (scavenge-call cc))
+ (lambda-var (scavenge-closure-var cc))
+ (entry (scavenge-entry cc))))
+ (when (eq (lambda-kind clambda) :external)
+ (mapc #'scavenge-call (find-reference-funs clambda))))
+ ;; Voila.
+ res)))))
;;; Return true if CLAMBDA either is an XEP or has EXITS to some of
;;; its ENTRIES.
(declare (type clambda clambda))
(or (eq (functional-kind clambda) :external)
(let ((entries (lambda-entries clambda)))
- (and entries
- (find-if #'entry-exits entries)))))
+ (and entries
+ (find-if #'entry-exits entries)))))
;;; Compute the result of FIND-INITIAL-DFO given the list of all
;;; resulting components. Components with a :TOPLEVEL lambda, but no
(defun separate-toplevelish-components (components)
(declare (list components))
(collect ((real)
- (top)
- (real-top))
+ (top)
+ (real-top))
(dolist (component components)
(unless (eq (block-next (component-head component))
- (component-tail component))
- (let* ((funs (component-lambdas component))
- (has-top (find :toplevel funs :key #'functional-kind))
- (has-external-references
- (some #'functional-has-external-references-p funs)))
- (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
- ;; is newer than the rest of this function, and
- ;; doesn't really seem to fit into its mindset. Here
- ;; we mark components which contain such FUNCTIONs
- ;; them as :COMPLEX-TOPLEVEL, since they do get
- ;; executed at run time, and since it's not valid to
- ;; delete them just because they don't have any
- ;; references from pure :TOPLEVEL components. -- WHN
- has-external-references
- (setf (component-kind component) :complex-toplevel)
- (real component)
- (real-top component))
- ((or (some #'has-xep-or-nlx funs)
- (and has-top (rest funs)))
- (setf (component-name component)
- (find-component-name component))
- (real component)
- (when has-top
- (setf (component-kind component) :complex-toplevel)
- (real-top component)))
- (has-top
- (setf (component-kind component) :toplevel)
- (setf (component-name component) "top level form")
- (top component))
- (t
- (delete-component component))))))
+ (component-tail component))
+ (let* ((funs (component-lambdas component))
+ (has-top (find :toplevel funs :key #'functional-kind))
+ (has-external-references
+ (some #'functional-has-external-references-p funs)))
+ (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
+ ;; is newer than the rest of this function, and
+ ;; doesn't really seem to fit into its mindset. Here
+ ;; we mark components which contain such FUNCTIONs
+ ;; them as :COMPLEX-TOPLEVEL, since they do get
+ ;; executed at run time, and since it's not valid to
+ ;; delete them just because they don't have any
+ ;; references from pure :TOPLEVEL components. -- WHN
+ has-external-references
+ (setf (component-kind component) :complex-toplevel)
+ (real component)
+ (real-top component))
+ ((or (some #'has-xep-or-nlx funs)
+ (and has-top (rest funs)))
+ (setf (component-name component)
+ (find-component-name component))
+ (real component)
+ (when has-top
+ (setf (component-kind component) :complex-toplevel)
+ (real-top component)))
+ (has-top
+ (setf (component-kind component) :toplevel)
+ (setf (component-name component) "top level form")
+ (top component))
+ (t
+ (delete-component component))))))
(values (real) (top) (real-top))))
;; are moved to the appropriate new component tail.
(dolist (toplevel-lambda toplevel-lambdas)
(let* ((old-component (lambda-component toplevel-lambda))
- (old-component-lambdas (component-lambdas old-component))
- (new-component nil))
- (aver (member toplevel-lambda old-component-lambdas))
- (dolist (component-lambda old-component-lambdas)
- (aver (member (functional-kind component-lambda)
- '(:optional :external :toplevel nil :escape
- :cleanup)))
- (unless new-component
- (setf new-component (make-empty-component))
- (setf (component-name new-component)
- ;; This isn't necessarily an ideal name for the
- ;; component, since it might end up with multiple
- ;; lambdas in it, not just this one, but it does
- ;; seem a better name than just "<unknown>".
+ (old-component-lambdas (component-lambdas old-component))
+ (new-component nil))
+ (aver (member toplevel-lambda old-component-lambdas))
+ (dolist (component-lambda old-component-lambdas)
+ (aver (member (functional-kind component-lambda)
+ '(:optional :external :toplevel nil :escape
+ :cleanup)))
+ (unless new-component
+ (setf new-component (make-empty-component))
+ (setf (component-name new-component)
+ ;; This isn't necessarily an ideal name for the
+ ;; component, since it might end up with multiple
+ ;; lambdas in it, not just this one, but it does
+ ;; seem a better name than just "<unknown>".
(leaf-debug-name component-lambda)))
- (let ((res (dfo-scavenge-dependency-graph component-lambda
- new-component)))
- (when (eq res new-component)
- (aver (not (position new-component (components))))
- (components new-component)
- (setq new-component nil))))
- (when (eq (component-kind old-component) :initial)
- (aver (null (component-lambdas old-component)))
- (let ((tail (component-tail old-component)))
- (dolist (pred (block-pred tail))
- (let ((pred-component (block-component pred)))
- (unless (eq pred-component old-component)
- (unlink-blocks pred tail)
- (link-blocks pred (component-tail pred-component))))))
- (delete-component old-component))))
+ (let ((res (dfo-scavenge-dependency-graph component-lambda
+ new-component)))
+ (when (eq res new-component)
+ (aver (not (position new-component (components))))
+ (components new-component)
+ (setq new-component nil))))
+ (when (eq (component-kind old-component) :initial)
+ (aver (null (component-lambdas old-component)))
+ (let ((tail (component-tail old-component)))
+ (dolist (pred (block-pred tail))
+ (let ((pred-component (block-component pred)))
+ (unless (eq pred-component old-component)
+ (unlink-blocks pred tail)
+ (link-blocks pred (component-tail pred-component))))))
+ (delete-component old-component))))
;; When we are done, we assign DFNs.
(dolist (component (components))
(let ((num 0))
- (declare (fixnum num))
- (do-blocks-backwards (block component :both)
- (setf (block-number block) (incf num)))))
+ (declare (fixnum num))
+ (do-blocks-backwards (block component :both)
+ (setf (block-number block) (incf num)))))
;; Pull out top-level-ish code.
(separate-toplevelish-components (components))))
(setf (lambda-physenv let) (lambda-physenv result-lambda))
(push let (lambda-lets result-lambda)))
(setf (lambda-entries result-lambda)
- (nconc (lambda-entries result-lambda)
- (lambda-entries lambda)))
+ (nconc (lambda-entries result-lambda)
+ (lambda-entries lambda)))
(let* ((bind (lambda-bind lambda))
- (bind-block (node-block bind))
- (component (block-component bind-block))
- (result-component (lambda-component result-lambda))
- (result-return-block (node-block (lambda-return result-lambda))))
+ (bind-block (node-block bind))
+ (component (block-component bind-block))
+ (result-component (lambda-component result-lambda))
+ (result-return-block (node-block (lambda-return result-lambda))))
;; Move blocks into the new COMPONENT, and move any nodes directly
;; in the old LAMBDA into the new one (with LETs implicitly moved
;; by changing their home.)
(do-blocks (block component)
(do-nodes (node nil block)
- (let ((lexenv (node-lexenv node)))
- (when (eq (lexenv-lambda lexenv) lambda)
- (setf (lexenv-lambda lexenv) result-lambda))))
+ (let ((lexenv (node-lexenv node)))
+ (when (eq (lexenv-lambda lexenv) lambda)
+ (setf (lexenv-lambda lexenv) result-lambda))))
(setf (block-component block) result-component))
;; Splice the blocks into the new DFO, and unlink them from the
;; old component head and tail. Non-return blocks that jump to the
;; tail (NIL-returning calls) are switched to go to the new tail.
(let* ((head (component-head component))
- (first (block-next head))
- (tail (component-tail component))
- (last (block-prev tail))
- (prev (block-prev result-return-block)))
+ (first (block-next head))
+ (tail (component-tail component))
+ (last (block-prev tail))
+ (prev (block-prev result-return-block)))
(setf (block-next prev) first)
(setf (block-prev first) prev)
(setf (block-next last) result-return-block)
(setf (block-prev result-return-block) last)
(dolist (succ (block-succ head))
- (unlink-blocks head succ))
+ (unlink-blocks head succ))
(dolist (pred (block-pred tail))
- (unlink-blocks pred tail)
- (let ((last (block-last pred)))
- (unless (return-p last)
- (aver (basic-combination-p last))
- (link-blocks pred (component-tail result-component))))))
+ (unlink-blocks pred tail)
+ (let ((last (block-last pred)))
+ (unless (return-p last)
+ (aver (basic-combination-p last))
+ (link-blocks pred (component-tail result-component))))))
(let ((lambdas (component-lambdas component)))
(aver (and (null (rest lambdas))
- (eq (first lambdas) lambda))))
+ (eq (first lambdas) lambda))))
;; Switch the end of the code from the return block to the start of
;; the next chunk.
;; is always a preceding REF NIL node in top level lambdas.
(let ((return (lambda-return lambda)))
(when return
- (link-blocks (node-block return) result-return-block)
+ (link-blocks (node-block return) result-return-block)
(flush-dest (return-result return))
(unlink-node return)))))
(defun merge-toplevel-lambdas (lambdas)
(declare (cons lambdas))
(let* ((result-lambda (first lambdas))
- (result-return (lambda-return result-lambda)))
+ (result-return (lambda-return result-lambda)))
(cond
(result-return
;; Make sure the result's return node starts a block so that we
;; can splice code in before it.
(let ((prev (node-prev
- (lvar-uses (return-result result-return)))))
- (when (ctran-use prev)
- (node-ends-block (ctran-use prev))))
+ (lvar-uses (return-result result-return)))))
+ (when (ctran-use prev)
+ (node-ends-block (ctran-use prev))))
(dolist (lambda (rest lambdas))
- (merge-1-toplevel-lambda result-lambda lambda)))
+ (merge-1-toplevel-lambda result-lambda lambda)))
(t
(dolist (lambda (rest lambdas))
- (setf (functional-entry-fun lambda) nil)
- (delete-component (lambda-component lambda)))))
+ (setf (functional-entry-fun lambda) nil)
+ (delete-component (lambda-component lambda)))))
(values (lambda-component result-lambda) result-lambda)))
;;; value of zero disables the printing of instruction bytes.
(defvar *disassem-inst-column-width* 16
#!+sb-doc
- "The width of instruction bytes.")
+ "The width of instruction bytes.")
(declaim (type text-width *disassem-inst-column-width*))
-
+
(defvar *disassem-note-column* (+ 45 *disassem-inst-column-width*)
#!+sb-doc
(defvar *disassem-fun-cache* (make-fun-cache))
(defstruct (arg (:copier nil)
- (:predicate nil))
+ (:predicate nil))
(name nil :type symbol)
(fields nil :type list)
(defun funstate-compatible-p (funstate args)
(every (lambda (this-arg-temps)
- (let* ((old-arg (car this-arg-temps))
- (new-arg (find (arg-name old-arg) args :key #'arg-name)))
- (and new-arg
+ (let* ((old-arg (car this-arg-temps))
+ (new-arg (find (arg-name old-arg) args :key #'arg-name)))
+ (and new-arg
(= (arg-position old-arg) (arg-position new-arg))
- (every (lambda (this-kind-temps)
- (funcall (find-arg-form-checker
- (car this-kind-temps))
- new-arg
- old-arg))
- (cdr this-arg-temps)))))
+ (every (lambda (this-kind-temps)
+ (funcall (find-arg-form-checker
+ (car this-kind-temps))
+ new-arg
+ old-arg))
+ (cdr this-arg-temps)))))
(funstate-arg-temps funstate)))
(defun arg-or-lose (name funstate)
(defun filter-overrides (overrides evalp)
(mapcar (lambda (override)
- (list* (car override) (cadr override)
- (munge-fun-refs (cddr override) evalp)))
+ (list* (car override) (cadr override)
+ (munge-fun-refs (cddr override) evalp)))
overrides))
(defparameter *arg-fun-params*
(let ((args-var (gensym)))
`(let ((,args-var (copy-list (format-args ,format-form))))
,@(mapcar (lambda (override)
- (update-args-form args-var
- `',(car override)
- (and (cdr override)
- (cons :value (cdr override)))
- evalp))
+ (update-args-form args-var
+ `',(car override)
+ (and (cdr override)
+ (cons :value (cdr override)))
+ evalp))
overrides)
,args-var)))
(defun gen-printer-def-forms-def-form (base-name
- uniquified-name
- def
- &optional
- (evalp t))
+ uniquified-name
+ def
+ &optional
+ (evalp t))
(declare (type symbol base-name))
(declare (type (or symbol string) uniquified-name))
(destructuring-bind
(funcache *disassem-fun-cache*))
(multiple-value-bind (printer-fun printer-defun)
(find-printer-fun ',uniquified-name
- ',format-name
- ,(if (eq printer-form :default)
+ ',format-name
+ ,(if (eq printer-form :default)
`(format-default-printer ,format-var)
(maybe-quote evalp printer-form))
args funcache)
(find-labeller-fun ',uniquified-name args funcache)
(multiple-value-bind (prefilter-fun prefilter-defun)
(find-prefilter-fun ',uniquified-name
- ',format-name
- args
- funcache)
+ ',format-name
+ args
+ funcache)
(multiple-value-bind (mask id)
(compute-mask-id args)
(values
(eval
`(progn
,@(mapcar (lambda (arg)
- (when (arg-fields arg)
- (gen-arg-access-macro-def-form
- arg ,args-var ',name)))
+ (when (arg-fields arg)
+ (gen-arg-access-macro-def-form
+ arg ,args-var ',name)))
,args-var))))))))))
;;; FIXME: probably needed only at build-the-system time, not in
(push arg (cdr (last args))))
arg)
(setf (nth arg-pos args)
- (copy-structure (nth arg-pos args))))))
+ (copy-structure (nth arg-pos args))))))
(when (and field-p (not fields-p))
(setf fields (list field))
(setf fields-p t))
arg-name))
(setf (arg-fields arg)
(mapcar (lambda (bytespec)
- (when (> (+ (byte-position bytespec)
- (byte-size bytespec))
- format-length)
- (error "~@<in arg ~S: ~3I~:_~
+ (when (> (+ (byte-position bytespec)
+ (byte-size bytespec))
+ format-length)
+ (error "~@<in arg ~S: ~3I~:_~
The field ~S doesn't fit in an ~
instruction-format ~W bits wide.~:>"
- arg-name
- bytespec
- format-length))
- (correct-dchunk-bytespec-for-endianness
- bytespec
- format-length
- sb!c:*backend-byte-order*))
+ arg-name
+ bytespec
+ format-length))
+ (correct-dchunk-bytespec-for-endianness
+ bytespec
+ format-length
+ sb!c:*backend-byte-order*))
fields)))
args))
(push `(,(cadr atk) ,(cddr atk)) bindings))
(t
(mapc (lambda (var form)
- (push `(,var ,form) bindings))
+ (push `(,var ,form) bindings))
(cadr atk)
(cddr atk))))))
bindings))
;;;
;;; :TYPE arg-type-name
;;; Inherit any properties of given arg-type.
-;;;
+;;;
;;; :PREFILTER function
;;; A function which is called (along with all other prefilters,
;;; in the order that their arguments appear in the instruction-
;;; format) before any printing is done, to filter the raw value.
;;; Any uses of READ-SUFFIX must be done inside a prefilter.
-;;;
+;;;
;;; :PRINTER function-string-or-vector
;;; A function, string, or vector which is used to print an argument of
;;; this type.
-;;;
+;;;
;;; :USE-LABEL
;;; If non-NIL, the value of an argument of this type is used as
;;; an address, and if that address occurs inside the disassembled
(defmacro def-arg-form-kind ((&rest names) &rest inits)
`(let ((kind (make-arg-form-kind :names ',names ,@inits)))
,@(mapcar (lambda (name)
- `(setf (getf *arg-form-kinds* ',name) kind))
+ `(setf (getf *arg-form-kinds* ',name) kind))
names)))
(def-arg-form-kind (:raw)
:producer (lambda (arg funstate)
- (declare (ignore funstate))
- (mapcar (lambda (bytespec)
- `(the (unsigned-byte ,(byte-size bytespec))
- (local-extract ',bytespec)))
- (arg-fields arg)))
+ (declare (ignore funstate))
+ (mapcar (lambda (bytespec)
+ `(the (unsigned-byte ,(byte-size bytespec))
+ (local-extract ',bytespec)))
+ (arg-fields arg)))
:checker (lambda (new-arg old-arg)
- (equal (arg-fields new-arg)
- (arg-fields old-arg))))
+ (equal (arg-fields new-arg)
+ (arg-fields old-arg))))
(def-arg-form-kind (:sign-extended :unfiltered)
:producer (lambda (arg funstate)
- (let ((raw-forms (gen-arg-forms arg :raw funstate)))
- (if (and (arg-sign-extend-p arg) (listp raw-forms))
- (mapcar (lambda (form field)
- `(the (signed-byte ,(byte-size field))
- (sign-extend ,form
- ,(byte-size field))))
- raw-forms
- (arg-fields arg))
- raw-forms)))
+ (let ((raw-forms (gen-arg-forms arg :raw funstate)))
+ (if (and (arg-sign-extend-p arg) (listp raw-forms))
+ (mapcar (lambda (form field)
+ `(the (signed-byte ,(byte-size field))
+ (sign-extend ,form
+ ,(byte-size field))))
+ raw-forms
+ (arg-fields arg))
+ raw-forms)))
:checker (lambda (new-arg old-arg)
- (equal (arg-sign-extend-p new-arg)
- (arg-sign-extend-p old-arg))))
+ (equal (arg-sign-extend-p new-arg)
+ (arg-sign-extend-p old-arg))))
(defun valsrc-equal (f1 f2)
(if (null f1)
(def-arg-form-kind (:filtering)
:producer (lambda (arg funstate)
- (let ((sign-extended-forms
- (gen-arg-forms arg :sign-extended funstate))
- (pf (arg-prefilter arg)))
- (if pf
- (values
- `(local-filter ,(maybe-listify sign-extended-forms)
- ,(source-form pf))
- t)
- (values sign-extended-forms nil))))
+ (let ((sign-extended-forms
+ (gen-arg-forms arg :sign-extended funstate))
+ (pf (arg-prefilter arg)))
+ (if pf
+ (values
+ `(local-filter ,(maybe-listify sign-extended-forms)
+ ,(source-form pf))
+ t)
+ (values sign-extended-forms nil))))
:checker (lambda (new-arg old-arg)
- (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
+ (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
(def-arg-form-kind (:filtered :unadjusted)
:producer (lambda (arg funstate)
- (let ((pf (arg-prefilter arg)))
- (if pf
- (values `(local-filtered-value ,(arg-position arg)) t)
- (gen-arg-forms arg :sign-extended funstate))))
+ (let ((pf (arg-prefilter arg)))
+ (if pf
+ (values `(local-filtered-value ,(arg-position arg)) t)
+ (gen-arg-forms arg :sign-extended funstate))))
:checker (lambda (new-arg old-arg)
- (let ((pf1 (arg-prefilter new-arg))
- (pf2 (arg-prefilter old-arg)))
- (if (null pf1)
- (null pf2)
- (= (arg-position new-arg)
- (arg-position old-arg))))))
+ (let ((pf1 (arg-prefilter new-arg))
+ (pf2 (arg-prefilter old-arg)))
+ (if (null pf1)
+ (null pf2)
+ (= (arg-position new-arg)
+ (arg-position old-arg))))))
(def-arg-form-kind (:adjusted :numeric :unlabelled)
:producer (lambda (arg funstate)
- (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
- (use-label (arg-use-label arg)))
- (if (and use-label (not (eq use-label t)))
- (list
- `(adjust-label ,(maybe-listify filtered-forms)
- ,(source-form use-label)))
- filtered-forms)))
+ (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
+ (use-label (arg-use-label arg)))
+ (if (and use-label (not (eq use-label t)))
+ (list
+ `(adjust-label ,(maybe-listify filtered-forms)
+ ,(source-form use-label)))
+ filtered-forms)))
:checker (lambda (new-arg old-arg)
- (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
+ (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
(def-arg-form-kind (:labelled :final)
:producer (lambda (arg funstate)
- (let ((adjusted-forms
- (gen-arg-forms arg :adjusted funstate))
- (use-label (arg-use-label arg)))
- (if use-label
- (let ((form (maybe-listify adjusted-forms)))
- (if (and (not (eq use-label t))
- (not (atom adjusted-forms))
- (/= (length adjusted-forms) 1))
- (pd-error
- "cannot label a multiple-field argument ~
+ (let ((adjusted-forms
+ (gen-arg-forms arg :adjusted funstate))
+ (use-label (arg-use-label arg)))
+ (if use-label
+ (let ((form (maybe-listify adjusted-forms)))
+ (if (and (not (eq use-label t))
+ (not (atom adjusted-forms))
+ (/= (length adjusted-forms) 1))
+ (pd-error
+ "cannot label a multiple-field argument ~
unless using a function: ~S" arg)
- `((lookup-label ,form))))
- adjusted-forms)))
+ `((lookup-label ,form))))
+ adjusted-forms)))
:checker (lambda (new-arg old-arg)
- (let ((lf1 (arg-use-label new-arg))
- (lf2 (arg-use-label old-arg)))
- (if (null lf1) (null lf2) t))))
+ (let ((lf1 (arg-use-label new-arg))
+ (lf2 (arg-use-label old-arg)))
+ (if (null lf1) (null lf2) t))))
;;; This is a bogus kind that's just used to ensure that printers are
;;; compatible...
(def-arg-form-kind (:printed)
:producer (lambda (&rest noise)
- (declare (ignore noise))
- (pd-error "bogus! can't use the :printed value of an arg!"))
+ (declare (ignore noise))
+ (pd-error "bogus! can't use the :printed value of an arg!"))
:checker (lambda (new-arg old-arg)
- (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
+ (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
(defun remember-printer-use (arg funstate)
(set-arg-temps nil nil arg :printed funstate))
thing))
\f
(defstruct (cached-fun (:conc-name cached-fun-)
- (:copier nil))
+ (:copier nil))
(funstate nil :type (or null funstate))
(constraint nil :type list)
(name nil :type (or null symbol)))
(return cached-fun)))))
(defmacro !with-cached-fun ((name-var
- funstate-var
- cache
- cache-slot
- args
- &key
- constraint
- (stem (missing-arg)))
- &body defun-maker-forms)
+ funstate-var
+ cache
+ cache-slot
+ args
+ &key
+ constraint
+ (stem (missing-arg)))
+ &body defun-maker-forms)
(let ((cache-var (gensym))
(constraint-var (gensym)))
`(let* ((,constraint-var ,constraint)
(,cache-var (find-cached-fun (,cache-slot ,cache)
- ,args ,constraint-var)))
+ ,args ,constraint-var)))
(cond (,cache-var
(values (cached-fun-name ,cache-var) nil))
(t
(,funstate-var (make-funstate ,args))
(,cache-var
(make-cached-fun :name ,name-var
- :funstate ,funstate-var
- :constraint ,constraint-var)))
+ :funstate ,funstate-var
+ :constraint ,constraint-var)))
(values ,name-var
`(progn
,(progn ,@defun-maker-forms)
(if (null printer-source)
(values nil nil)
(let ((printer-source (preprocess-printer printer-source args)))
- (!with-cached-fun
- (name funstate cache fun-cache-printers args
- :constraint printer-source
- :stem (concatenate 'string
- (string %name)
- "-"
- (symbol-name %format-name)
- "-PRINTER"))
- (make-printer-defun printer-source funstate name)))))
+ (!with-cached-fun
+ (name funstate cache fun-cache-printers args
+ :constraint printer-source
+ :stem (concatenate 'string
+ (string %name)
+ "-"
+ (symbol-name %format-name)
+ "-PRINTER"))
+ (make-printer-defun printer-source funstate name)))))
\f
(defun make-printer-defun (source funstate fun-name)
(let ((printer-form (compile-printer-list source funstate))
key
(sharing-mapcar
(lambda (sub-test)
- (preprocess-test subj sub-test args))
+ (preprocess-test subj sub-test args))
body))))
(t form)))))
:cond
(sharing-mapcar
(lambda (clause)
- (let ((filtered-body
- (sharing-mapcar
- (lambda (sub-printer)
- (preprocess-conditionals sub-printer args))
- (cdr clause))))
- (sharing-cons
- clause
- (preprocess-test (find-first-field-name filtered-body)
- (car clause)
- args)
- filtered-body)))
+ (let ((filtered-body
+ (sharing-mapcar
+ (lambda (sub-printer)
+ (preprocess-conditionals sub-printer args))
+ (cdr clause))))
+ (sharing-cons
+ clause
+ (preprocess-test (find-first-field-name filtered-body)
+ (car clause)
+ args)
+ filtered-body)))
(cdr printer))))
(quote printer)
(t
(sharing-mapcar
(lambda (sub-printer)
- (preprocess-conditionals sub-printer args))
+ (preprocess-conditionals sub-printer args))
printer)))))
;;; Return a version of the disassembly-template PRINTER with
`(local-call-global-printer ,source))
((eq (car source) :cond)
`(cond ,@(mapcar (lambda (clause)
- `(,(compile-test (find-first-field-name
- (cdr clause))
- (car clause)
- funstate)
- ,@(compile-printer-list (cdr clause)
- funstate)))
+ `(,(compile-test (find-first-field-name
+ (cdr clause))
+ (car clause)
+ funstate)
+ ,@(compile-printer-list (cdr clause)
+ funstate)))
(cdr source))))
;; :IF, :UNLESS, and :WHEN are replaced by :COND during preprocessing
(t
(unless (and (= (length (arg-fields arg1))
(length (arg-fields arg2)))
(every (lambda (bs1 bs2)
- (= (byte-size bs1) (byte-size bs2)))
+ (= (byte-size bs1) (byte-size bs2)))
(arg-fields arg1)
(arg-fields arg2)))
(pd-error "can't compare differently sized fields: ~
(defun find-prefilter-fun (%name %format-name args cache)
(declare (type (or symbol string) %name %format-name))
(let ((filtered-args (mapcar #'arg-name
- (remove-if-not #'arg-prefilter args))))
+ (remove-if-not #'arg-prefilter args))))
(if (null filtered-args)
(values nil nil)
(!with-cached-fun
(name funstate cache fun-cache-prefilters args
:stem (concatenate 'string
- (string %name)
- "-"
- (string %format-name)
- "-PREFILTER")
+ (string %name)
+ "-"
+ (string %format-name)
+ "-PREFILTER")
:constraint filtered-args)
(collect ((forms))
(dolist (arg args)
;;; information so that we can allow garbage collect during disassembly and
;;; not get tripped up by a code block being moved...
(defstruct (disassem-state (:conc-name dstate-)
- (:constructor %make-dstate)
- (:copier nil))
+ (:constructor %make-dstate)
+ (:copier nil))
;; offset of current pos in segment
- (cur-offs 0 :type offset)
+ (cur-offs 0 :type offset)
;; offset of next position
- (next-offs 0 :type offset)
+ (next-offs 0 :type offset)
;; a sap pointing to our segment
(segment-sap (missing-arg) :type sb!sys:system-area-pointer)
- ;; the current segment
- (segment nil :type (or null segment))
+ ;; the current segment
+ (segment nil :type (or null segment))
;; what to align to in most cases
- (alignment sb!vm:n-word-bytes :type alignment)
+ (alignment sb!vm:n-word-bytes :type alignment)
(byte-order :little-endian
- :type (member :big-endian :little-endian))
+ :type (member :big-endian :little-endian))
;; for user code to hang stuff off of
(properties nil :type list)
;; for user code to hang stuff off of, cleared each time before an
;; instruction is processed
(inst-properties nil :type list)
(filtered-values (make-array max-filtered-value-index)
- :type filtered-value-vector)
+ :type filtered-value-vector)
;; used for prettifying printing
(addr-print-len nil :type (or null (integer 0 20)))
(argument-column 0 :type column)
;; to make output look nicer
- (output-state :beginning
- :type (member :beginning
- :block-boundary
- nil))
+ (output-state :beginning
+ :type (member :beginning
+ :block-boundary
+ nil))
;; alist of (address . label-number)
- (labels nil :type list)
+ (labels nil :type list)
;; same as LABELS slot data, but in a different form
(label-hash (make-hash-table) :type hash-table)
;; list of function
- (fun-hooks nil :type list)
+ (fun-hooks nil :type list)
;; alist of (address . label-number), popped as it's used
(cur-labels nil :type list)
;; OFFS-HOOKs, popped as they're used
- (cur-offs-hooks nil :type list)
+ (cur-offs-hooks nil :type list)
;; for the current location
(notes nil :type list)
(def!method print-object ((dstate disassem-state) stream)
(print-unreadable-object (dstate stream :type t)
(format stream
- "+~W~@[ in ~S~]"
- (dstate-cur-offs dstate)
- (dstate-segment dstate))))
+ "+~W~@[ in ~S~]"
+ (dstate-cur-offs dstate)
+ (dstate-segment dstate))))
;;; Return the absolute address of the current instruction in DSTATE.
(defun dstate-cur-addr (dstate)
(the address (+ (seg-virtual-location (dstate-segment dstate))
- (dstate-cur-offs dstate))))
+ (dstate-cur-offs dstate))))
;;; Return the absolute address of the next instruction in DSTATE.
(defun dstate-next-addr (dstate)
(the address (+ (seg-virtual-location (dstate-segment dstate))
- (dstate-next-offs dstate))))
+ (dstate-next-offs dstate))))
;;; Get the value of the property called NAME in DSTATE. Also SETF'able.
;;;
;;; know about dumping to a fasl file. (We need to objectify the
;;; state because the fasdumper must be reentrant.)
(defstruct (fasl-output
- #-no-ansi-print-object
- (:print-object (lambda (x s)
- (print-unreadable-object (x s :type t)
- (prin1 (namestring (fasl-output-stream x))
- s))))
- (:copier nil))
+ #-no-ansi-print-object
+ (:print-object (lambda (x s)
+ (print-unreadable-object (x s :type t)
+ (prin1 (namestring (fasl-output-stream x))
+ s))))
+ (:copier nil))
;; the stream we dump to
(stream (missing-arg) :type stream)
;; hashtables we use to keep track of dumped constants so that we
;;; optimizations should be conditional on #!+SB-FROZEN.
(defmacro dump-fop (fs file)
(let* ((fs (eval fs))
- (val (get fs 'fop-code)))
+ (val (get fs 'fop-code)))
(if val
`(progn
- #!+sb-show
- (when *fop-nop4-count*
- (dump-byte ,(get 'fop-nop4 'fop-code) ,file)
- (dump-integer-as-n-bytes (mod (incf *fop-nop4-count*) (expt 2 32))
+ #!+sb-show
+ (when *fop-nop4-count*
+ (dump-byte ,(get 'fop-nop4 'fop-code) ,file)
+ (dump-integer-as-n-bytes (mod (incf *fop-nop4-count*) (expt 2 32))
4 ,file))
- (dump-byte ',val ,file))
+ (dump-byte ',val ,file))
(error "compiler bug: ~S is not a legal fasload operator." fs))))
;;; Dump a FOP-CODE along with an integer argument, choosing the FOP
;;; compiler-macro expansion.
(defmacro dump-fop* (n byte-fop word-fop file)
(once-only ((n-n n)
- (n-file file))
+ (n-file file))
`(cond ((< ,n-n 256)
- (dump-fop ',byte-fop ,n-file)
- (dump-byte ,n-n ,n-file))
- (t
- (dump-fop ',word-fop ,n-file)
- (dump-word ,n-n ,n-file)))))
+ (dump-fop ',byte-fop ,n-file)
+ (dump-byte ,n-n ,n-file))
+ (t
+ (dump-fop ',word-fop ,n-file)
+ (dump-word ,n-n ,n-file)))))
;;; Push the object at table offset Handle on the fasl stack.
(defun dump-push (handle fasl-output)
;;; encodings -- CSR, 2002-04-25
(defun fasl-write-string (string stream)
(loop for char across string
- do (let ((code (char-code char)))
- (aver (<= 0 code 127))
- (write-byte code stream))))
+ do (let ((code (char-code char)))
+ (aver (<= 0 code 127))
+ (write-byte code stream))))
;;; Open a fasl file, write its header, and return a FASL-OUTPUT
;;; object for dumping to it. Some human-readable information about
-;;; the source code is given by the string WHERE.
+;;; the source code is given by the string WHERE.
(defun open-fasl-output (name where)
(declare (type pathname name))
(let* ((stream (open name
- :direction :output
- :if-exists :supersede
- :element-type 'sb!assem:assembly-unit))
- (res (make-fasl-output :stream stream)))
+ :direction :output
+ :if-exists :supersede
+ :element-type 'sb!assem:assembly-unit))
+ (res (make-fasl-output :stream stream)))
;; Begin the header with the constant machine-readable (and
;; semi-human-readable) string which is used to identify fasl files.
(fasl-write-string
(with-standard-io-syntax
(let ((*print-readably* nil)
- (*print-pretty* nil))
- (format nil
- "~% ~
+ (*print-pretty* nil))
+ (format nil
+ "~% ~
compiled from ~S~% ~
at ~A~% ~
on ~A~% ~
using ~A version ~A~%"
- where
- (format-universal-time nil (get-universal-time))
- (machine-instance)
- (sb!xc:lisp-implementation-type)
- (sb!xc:lisp-implementation-version))))
+ where
+ (format-universal-time nil (get-universal-time))
+ (machine-instance)
+ (sb!xc:lisp-implementation-type)
+ (sb!xc:lisp-implementation-version))))
stream)
(dump-byte +fasl-header-string-stop-char-code+ res)
;; Finish the header by outputting fasl file implementation,
;; version, and key *FEATURES*.
(flet ((dump-counted-string (string)
- (dump-word (length string) res)
- (dotimes (i (length string))
- (dump-byte (char-code (aref string i)) res))))
+ (dump-word (length string) res)
+ (dotimes (i (length string))
+ (dump-byte (char-code (aref string i)) res))))
(dump-counted-string (symbol-name +backend-fasl-file-implementation+))
- (dump-word +fasl-file-version+ res)
+ (dump-word +fasl-file-version+ res)
(dump-counted-string *features-affecting-fasl-format*))
res))
-;;; Close the specified FASL-OUTPUT, aborting the write if ABORT-P.
+;;; Close the specified FASL-OUTPUT, aborting the write if ABORT-P.
(defun close-fasl-output (fasl-output abort-p)
(declare (type fasl-output fasl-output))
(dump-fop 'fop-verify-empty-stack fasl-output)
(dump-fop 'fop-verify-table-size fasl-output)
(dump-word (fasl-output-table-free fasl-output)
- fasl-output)
+ fasl-output)
(dump-fop 'fop-end-group fasl-output)
;; That's all, folks.
(defun dump-non-immediate-object (x file)
(let ((index (gethash x (fasl-output-eq-table file))))
(cond ((and index (not *cold-load-dump*))
- (dump-push index file))
- (t
- (typecase x
- (symbol (dump-symbol x file))
- (list
- ;; KLUDGE: The code in this case has been hacked
- ;; to match Douglas Crosher's quick fix to CMU CL
- ;; (on cmucl-imp 1999-12-27), applied in sbcl-0.6.8.11
- ;; with help from Martin Atzmueller. This is not an
- ;; ideal solution; to quote DTC,
- ;; The compiler locks up trying to coalesce the
- ;; constant lists. The hack below will disable the
- ;; coalescing of lists while dumping and allows
+ (dump-push index file))
+ (t
+ (typecase x
+ (symbol (dump-symbol x file))
+ (list
+ ;; KLUDGE: The code in this case has been hacked
+ ;; to match Douglas Crosher's quick fix to CMU CL
+ ;; (on cmucl-imp 1999-12-27), applied in sbcl-0.6.8.11
+ ;; with help from Martin Atzmueller. This is not an
+ ;; ideal solution; to quote DTC,
+ ;; The compiler locks up trying to coalesce the
+ ;; constant lists. The hack below will disable the
+ ;; coalescing of lists while dumping and allows
;; the code to compile. The real fix would be to
- ;; take a little more care while dumping these.
- ;; So if better list coalescing is needed, start here.
- ;; -- WHN 2000-11-07
+ ;; take a little more care while dumping these.
+ ;; So if better list coalescing is needed, start here.
+ ;; -- WHN 2000-11-07
(if (cyclic-list-p x)
- (progn
- (dump-list x file)
- (eq-save-object x file))
- (unless (equal-check-table x file)
- (dump-list x file)
- (equal-save-object x file))))
- (layout
- (dump-layout x file)
- (eq-save-object x file))
- (instance
- (dump-structure x file)
- (eq-save-object x file))
- (array
+ (progn
+ (dump-list x file)
+ (eq-save-object x file))
+ (unless (equal-check-table x file)
+ (dump-list x file)
+ (equal-save-object x file))))
+ (layout
+ (dump-layout x file)
+ (eq-save-object x file))
+ (instance
+ (dump-structure x file)
+ (eq-save-object x file))
+ (array
;; DUMP-ARRAY (and its callees) are responsible for
;; updating the EQ and EQUAL hash tables.
- (dump-array x file))
- (number
- (unless (equal-check-table x file)
- (etypecase x
- (ratio (dump-ratio x file))
- (complex (dump-complex x file))
- (float (dump-float x file))
- (integer (dump-integer x file)))
- (equal-save-object x file)))
- (t
- ;; This probably never happens, since bad things tend to
- ;; be detected during IR1 conversion.
- (error "This object cannot be dumped into a fasl file:~% ~S"
- x))))))
+ (dump-array x file))
+ (number
+ (unless (equal-check-table x file)
+ (etypecase x
+ (ratio (dump-ratio x file))
+ (complex (dump-complex x file))
+ (float (dump-float x file))
+ (integer (dump-integer x file)))
+ (equal-save-object x file)))
+ (t
+ ;; This probably never happens, since bad things tend to
+ ;; be detected during IR1 conversion.
+ (error "This object cannot be dumped into a fasl file:~% ~S"
+ x))))))
(values))
;;; Dump an object of any type by dispatching to the correct
;;; assumed that there is a top level call to DUMP-OBJECT.
(defun sub-dump-object (x file)
(cond ((listp x)
- (if x
- (dump-non-immediate-object x file)
- (dump-fop 'fop-empty-list file)))
- ((symbolp x)
- (if (eq x t)
- (dump-fop 'fop-truth file)
- (dump-non-immediate-object x file)))
- ((fixnump x) (dump-integer x file))
- ((characterp x) (dump-character x file))
- (t
- (dump-non-immediate-object x file))))
+ (if x
+ (dump-non-immediate-object x file)
+ (dump-fop 'fop-empty-list file)))
+ ((symbolp x)
+ (if (eq x t)
+ (dump-fop 'fop-truth file)
+ (dump-non-immediate-object x file)))
+ ((fixnump x) (dump-integer x file))
+ ((characterp x) (dump-character x file))
+ (t
+ (dump-non-immediate-object x file))))
;;; Dump stuff to backpatch already dumped objects. INFOS is the list
;;; of CIRCULARITY structures describing what to do. The patching FOPs
(dolist (info infos)
(let* ((value (circularity-value info))
- (enclosing (circularity-enclosing-object info)))
- (dump-push (gethash enclosing table) file)
- (unless (eq enclosing value)
- (do ((current enclosing (cdr current))
- (i 0 (1+ i)))
- ((eq current value)
- (dump-fop 'fop-nthcdr file)
- (dump-word i file))
- (declare (type index i)))))
+ (enclosing (circularity-enclosing-object info)))
+ (dump-push (gethash enclosing table) file)
+ (unless (eq enclosing value)
+ (do ((current enclosing (cdr current))
+ (i 0 (1+ i)))
+ ((eq current value)
+ (dump-fop 'fop-nthcdr file)
+ (dump-word i file))
+ (declare (type index i)))))
(ecase (circularity-type info)
(:rplaca (dump-fop 'fop-rplaca file))
(defun dump-object (x file)
(if (compound-object-p x)
(let ((*circularities-detected* ())
- (circ (fasl-output-circularity-table file)))
- (clrhash circ)
- (sub-dump-object x file)
- (when *circularities-detected*
- (dump-circularities *circularities-detected* file)
- (clrhash circ)))
+ (circ (fasl-output-circularity-table file)))
+ (clrhash circ)
+ (sub-dump-object x file)
+ (when *circularities-detected*
+ (dump-circularities *circularities-detected* file)
+ (clrhash circ)))
(sub-dump-object x file)))
\f
;;;; LOAD-TIME-VALUE and MAKE-LOAD-FORM support
(defun fasl-dump-load-time-value-lambda (fun file)
(declare (type sb!c::clambda fun) (type fasl-output file))
(let ((handle (gethash (sb!c::leaf-info fun)
- (fasl-output-entry-table file))))
+ (fasl-output-entry-table file))))
(aver handle)
(dump-push handle file)
(dump-fop 'fop-funcall file)
;;; dumped if it's in the EQ table.
(defun fasl-constant-already-dumped-p (constant file)
(if (or (gethash constant (fasl-output-eq-table file))
- (gethash constant (fasl-output-valid-structures file)))
+ (gethash constant (fasl-output-valid-structures file)))
t
nil))
(defun dump-package (pkg file)
(declare (inline assoc))
(cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq)))
- (t
- (unless *cold-load-dump*
- (dump-fop 'fop-normal-load file))
+ (t
+ (unless *cold-load-dump*
+ (dump-fop 'fop-normal-load file))
#+sb-xc-host
- (dump-simple-base-string
+ (dump-simple-base-string
(coerce (package-name pkg) 'simple-base-string)
file)
#-sb-xc-host
- (#!+sb-unicode dump-simple-character-string
+ (#!+sb-unicode dump-simple-character-string
#!-sb-unicode dump-simple-base-string
- (coerce (package-name pkg) '(simple-array character (*)))
- file)
- (dump-fop 'fop-package file)
- (unless *cold-load-dump*
- (dump-fop 'fop-maybe-cold-load file))
- (let ((entry (dump-pop file)))
- (push (cons pkg entry) (fasl-output-packages file))
- entry))))
+ (coerce (package-name pkg) '(simple-array character (*)))
+ file)
+ (dump-fop 'fop-package file)
+ (unless *cold-load-dump*
+ (dump-fop 'fop-maybe-cold-load file))
+ (let ((entry (dump-pop file)))
+ (push (cons pkg entry) (fasl-output-packages file))
+ entry))))
\f
;;; dumper for lists
;;; This inhibits all circularity detection.
(defun dump-list (list file)
(aver (and list
- (not (gethash list (fasl-output-circularity-table file)))))
+ (not (gethash list (fasl-output-circularity-table file)))))
(do* ((l list (cdr l))
- (n 0 (1+ n))
- (circ (fasl-output-circularity-table file)))
+ (n 0 (1+ n))
+ (circ (fasl-output-circularity-table file)))
((atom l)
- (cond ((null l)
- (terminate-undotted-list n file))
- (t
- (sub-dump-object l file)
- (terminate-dotted-list n file))))
+ (cond ((null l)
+ (terminate-undotted-list n file))
+ (t
+ (sub-dump-object l file)
+ (terminate-dotted-list n file))))
(declare (type index n))
(let ((ref (gethash l circ)))
(when ref
- (push (make-circularity :type :rplacd
- :object list
- :index (1- n)
- :value l
- :enclosing-object ref)
- *circularities-detected*)
- (terminate-undotted-list n file)
- (return)))
+ (push (make-circularity :type :rplacd
+ :object list
+ :index (1- n)
+ :value l
+ :enclosing-object ref)
+ *circularities-detected*)
+ (terminate-undotted-list n file)
+ (return)))
(unless *cold-load-dump*
(setf (gethash l circ) list))
(let* ((obj (car l))
- (ref (gethash obj circ)))
+ (ref (gethash obj circ)))
(cond (ref
- (push (make-circularity :type :rplaca
- :object list
- :index n
- :value obj
- :enclosing-object ref)
- *circularities-detected*)
- (sub-dump-object nil file))
- (t
- (sub-dump-object obj file))))))
+ (push (make-circularity :type :rplaca
+ :object list
+ :index n
+ :value obj
+ :enclosing-object ref)
+ *circularities-detected*)
+ (sub-dump-object nil file))
+ (t
+ (sub-dump-object obj file))))))
(defun terminate-dotted-list (n file)
(declare (type index n) (type fasl-output file))
(7 (dump-fop 'fop-list*-7 file))
(8 (dump-fop 'fop-list*-8 file))
(t (do ((nn n (- nn 255)))
- ((< nn 256)
- (dump-fop 'fop-list* file)
- (dump-byte nn file))
- (declare (type index nn))
- (dump-fop 'fop-list* file)
- (dump-byte 255 file)))))
+ ((< nn 256)
+ (dump-fop 'fop-list* file)
+ (dump-byte nn file))
+ (declare (type index nn))
+ (dump-fop 'fop-list* file)
+ (dump-byte 255 file)))))
;;; If N > 255, must build list with one LIST operator, then LIST*
;;; operators.
(7 (dump-fop 'fop-list-7 file))
(8 (dump-fop 'fop-list-8 file))
(t (cond ((< n 256)
- (dump-fop 'fop-list file)
- (dump-byte n file))
- (t (dump-fop 'fop-list file)
- (dump-byte 255 file)
- (do ((nn (- n 255) (- nn 255)))
- ((< nn 256)
- (dump-fop 'fop-list* file)
- (dump-byte nn file))
- (declare (type index nn))
- (dump-fop 'fop-list* file)
- (dump-byte 255 file)))))))
+ (dump-fop 'fop-list file)
+ (dump-byte n file))
+ (t (dump-fop 'fop-list file)
+ (dump-byte 255 file)
+ (do ((nn (- n 255) (- nn 255)))
+ ((< nn 256)
+ (dump-fop 'fop-list* file)
+ (dump-byte nn file))
+ (declare (type index nn))
+ (dump-fop 'fop-list* file)
+ (dump-byte 255 file)))))))
\f
;;;; array dumping
;;; tables.
(defun dump-vector (x file)
(let ((simple-version (if (array-header-p x)
- (coerce x `(simple-array
- ,(array-element-type x)
- (*)))
- x)))
+ (coerce x `(simple-array
+ ,(array-element-type x)
+ (*)))
+ x)))
(typecase simple-version
#+sb-xc-host
(simple-string
#-sb-xc-host
(simple-base-string
(unless (string-check-table x file)
- (dump-simple-base-string simple-version file)
- (string-save-object x file)))
+ (dump-simple-base-string simple-version file)
+ (string-save-object x file)))
#-sb-xc-host
((simple-array character (*))
#!+sb-unicode
(unless (string-check-table x file)
- (dump-simple-character-string simple-version file)
- (string-save-object x file))
+ (dump-simple-character-string simple-version file)
+ (string-save-object x file))
#!-sb-unicode
(bug "how did we get here?"))
(simple-vector
((= index length)
(dump-fop* length fop-small-vector fop-vector file))
(let* ((obj (aref v index))
- (ref (gethash obj circ)))
+ (ref (gethash obj circ)))
(cond (ref
- (push (make-circularity :type :svset
- :object v
- :index index
- :value obj
- :enclosing-object ref)
- *circularities-detected*)
- (sub-dump-object nil file))
- (t
- (sub-dump-object obj file))))))
+ (push (make-circularity :type :svset
+ :object v
+ :index index
+ :value obj
+ :enclosing-object ref)
+ *circularities-detected*)
+ (sub-dump-object nil file))
+ (t
+ (sub-dump-object obj file))))))
;;; In the grand scheme of things I don't pretend to understand any
;;; more how this works, or indeed whether. But to write out specialized
(declare (type (simple-array * (*)) vec))
(let ((len (length vec)))
(labels ((dump-unsigned-vector (size bytes)
- (unless data-only
- (dump-fop 'fop-int-vector file)
- (dump-word len file)
- (dump-byte size file))
- ;; The case which is easy to handle in a portable way is when
- ;; the element size is a multiple of the output byte size, and
- ;; happily that's the only case we need to be portable. (The
- ;; cross-compiler has to output debug information (including
- ;; (SIMPLE-ARRAY (UNSIGNED-BYTE 8) *).) The other cases are only
- ;; needed in the target SBCL, so we let them be handled with
- ;; unportable bit bashing.
- (cond ((>= size 7) ; easy cases
- (multiple-value-bind (floor rem) (floor size 8)
- (aver (or (zerop rem) (= rem 7)))
- (when (= rem 7)
- (setq size (1+ size))
- (setq floor (1+ floor)))
- (dovector (i vec)
- (dump-integer-as-n-bytes
- (ecase sb!c:*backend-byte-order*
- (:little-endian i)
- (:big-endian (octet-swap i size)))
- floor file))))
- (t ; harder cases, not supported in cross-compiler
- (dump-raw-bytes vec bytes file))))
- (dump-signed-vector (size bytes)
- ;; Note: Dumping specialized signed vectors isn't
- ;; supported in the cross-compiler. (All cases here end
- ;; up trying to call DUMP-RAW-BYTES, which isn't
- ;; provided in the cross-compilation host, only on the
- ;; target machine.)
- (unless data-only
- (dump-fop 'fop-signed-int-vector file)
- (dump-word len file)
- (dump-byte size file))
- (dump-raw-bytes vec bytes file)))
+ (unless data-only
+ (dump-fop 'fop-int-vector file)
+ (dump-word len file)
+ (dump-byte size file))
+ ;; The case which is easy to handle in a portable way is when
+ ;; the element size is a multiple of the output byte size, and
+ ;; happily that's the only case we need to be portable. (The
+ ;; cross-compiler has to output debug information (including
+ ;; (SIMPLE-ARRAY (UNSIGNED-BYTE 8) *).) The other cases are only
+ ;; needed in the target SBCL, so we let them be handled with
+ ;; unportable bit bashing.
+ (cond ((>= size 7) ; easy cases
+ (multiple-value-bind (floor rem) (floor size 8)
+ (aver (or (zerop rem) (= rem 7)))
+ (when (= rem 7)
+ (setq size (1+ size))
+ (setq floor (1+ floor)))
+ (dovector (i vec)
+ (dump-integer-as-n-bytes
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian i)
+ (:big-endian (octet-swap i size)))
+ floor file))))
+ (t ; harder cases, not supported in cross-compiler
+ (dump-raw-bytes vec bytes file))))
+ (dump-signed-vector (size bytes)
+ ;; Note: Dumping specialized signed vectors isn't
+ ;; supported in the cross-compiler. (All cases here end
+ ;; up trying to call DUMP-RAW-BYTES, which isn't
+ ;; provided in the cross-compilation host, only on the
+ ;; target machine.)
+ (unless data-only
+ (dump-fop 'fop-signed-int-vector file)
+ (dump-word len file)
+ (dump-byte size file))
+ (dump-raw-bytes vec bytes file)))
(etypecase vec
- #-sb-xc-host
- ((simple-array nil (*))
- (dump-unsigned-vector 0 0))
- (simple-bit-vector
- (dump-unsigned-vector 1 (ceiling len 8))) ; bits to bytes
- ;; KLUDGE: This isn't the best way of expressing that the host
- ;; may not have specializations for (unsigned-byte 2) and
- ;; (unsigned-byte 4), which means that these types are
- ;; type-equivalent to (simple-array (unsigned-byte 8) (*));
- ;; the workaround is to remove them from the etypecase, since
- ;; they can't be dumped from the cross-compiler anyway. --
- ;; CSR, 2002-05-07
- #-sb-xc-host
- ((simple-array (unsigned-byte 2) (*))
- (dump-unsigned-vector 2 (ceiling (ash len 1) 8))) ; bits to bytes
- #-sb-xc-host
- ((simple-array (unsigned-byte 4) (*))
- (dump-unsigned-vector 4 (ceiling (ash len 2) 8))) ; bits to bytes
- #-sb-xc-host
- ((simple-array (unsigned-byte 7) (*))
- (dump-unsigned-vector 7 len))
- ((simple-array (unsigned-byte 8) (*))
- (dump-unsigned-vector 8 len))
- #-sb-xc-host
- ((simple-array (unsigned-byte 15) (*))
- (dump-unsigned-vector 15 (* 2 len)))
- ((simple-array (unsigned-byte 16) (*))
- (dump-unsigned-vector 16 (* 2 len)))
- #-sb-xc-host
- ((simple-array (unsigned-byte 31) (*))
- (dump-unsigned-vector 31 (* 4 len)))
- ((simple-array (unsigned-byte 32) (*))
- (dump-unsigned-vector 32 (* 4 len)))
+ #-sb-xc-host
+ ((simple-array nil (*))
+ (dump-unsigned-vector 0 0))
+ (simple-bit-vector
+ (dump-unsigned-vector 1 (ceiling len 8))) ; bits to bytes
+ ;; KLUDGE: This isn't the best way of expressing that the host
+ ;; may not have specializations for (unsigned-byte 2) and
+ ;; (unsigned-byte 4), which means that these types are
+ ;; type-equivalent to (simple-array (unsigned-byte 8) (*));
+ ;; the workaround is to remove them from the etypecase, since
+ ;; they can't be dumped from the cross-compiler anyway. --
+ ;; CSR, 2002-05-07
+ #-sb-xc-host
+ ((simple-array (unsigned-byte 2) (*))
+ (dump-unsigned-vector 2 (ceiling (ash len 1) 8))) ; bits to bytes
+ #-sb-xc-host
+ ((simple-array (unsigned-byte 4) (*))
+ (dump-unsigned-vector 4 (ceiling (ash len 2) 8))) ; bits to bytes
+ #-sb-xc-host
+ ((simple-array (unsigned-byte 7) (*))
+ (dump-unsigned-vector 7 len))
+ ((simple-array (unsigned-byte 8) (*))
+ (dump-unsigned-vector 8 len))
+ #-sb-xc-host
+ ((simple-array (unsigned-byte 15) (*))
+ (dump-unsigned-vector 15 (* 2 len)))
+ ((simple-array (unsigned-byte 16) (*))
+ (dump-unsigned-vector 16 (* 2 len)))
+ #-sb-xc-host
+ ((simple-array (unsigned-byte 31) (*))
+ (dump-unsigned-vector 31 (* 4 len)))
+ ((simple-array (unsigned-byte 32) (*))
+ (dump-unsigned-vector 32 (* 4 len)))
#-sb-xc-host
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((simple-array (unsigned-byte 63) (*))
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((simple-array (unsigned-byte 64) (*))
(dump-unsigned-vector 64 (* 8 len)))
- ((simple-array (signed-byte 8) (*))
- (dump-signed-vector 8 len))
- ((simple-array (signed-byte 16) (*))
- (dump-signed-vector 16 (* 2 len)))
+ ((simple-array (signed-byte 8) (*))
+ (dump-signed-vector 8 len))
+ ((simple-array (signed-byte 16) (*))
+ (dump-signed-vector 16 (* 2 len)))
#!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
- ((simple-array (unsigned-byte 29) (*))
- (dump-signed-vector 29 (* 4 len)))
+ ((simple-array (unsigned-byte 29) (*))
+ (dump-signed-vector 29 (* 4 len)))
#!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
- ((simple-array (signed-byte 30) (*))
- (dump-signed-vector 30 (* 4 len)))
- ((simple-array (signed-byte 32) (*))
- (dump-signed-vector 32 (* 4 len)))
+ ((simple-array (signed-byte 30) (*))
+ (dump-signed-vector 30 (* 4 len)))
+ ((simple-array (signed-byte 32) (*))
+ (dump-signed-vector 32 (* 4 len)))
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
((simple-array (unsigned-byte 60) (*))
(dump-signed-vector 60 (* 8 len)))
(defun dump-symbol (s file)
(declare (type fasl-output file))
(let* ((pname (symbol-name s))
- (pname-length (length pname))
- (pkg (symbol-package s)))
+ (pname-length (length pname))
+ (pkg (symbol-package s)))
(cond ((null pkg)
- (dump-fop* pname-length
- fop-uninterned-small-symbol-save
- fop-uninterned-symbol-save
- file))
- ;; CMU CL had FOP-SYMBOL-SAVE/FOP-SMALL-SYMBOL-SAVE fops which
- ;; used the current value of *PACKAGE*. Unfortunately that's
- ;; broken w.r.t. ANSI Common Lisp semantics, so those are gone
- ;; from SBCL.
- ;;((eq pkg *package*)
- ;; (dump-fop* pname-length
- ;; fop-small-symbol-save
- ;; fop-symbol-save file))
- ((eq pkg sb!int:*cl-package*)
- (dump-fop* pname-length
- fop-lisp-small-symbol-save
- fop-lisp-symbol-save
- file))
- ((eq pkg sb!int:*keyword-package*)
- (dump-fop* pname-length
- fop-keyword-small-symbol-save
- fop-keyword-symbol-save
- file))
- ((< pname-length 256)
- (dump-fop* (dump-package pkg file)
- fop-small-symbol-in-byte-package-save
- fop-small-symbol-in-package-save
- file)
- (dump-byte pname-length file))
- (t
- (dump-fop* (dump-package pkg file)
- fop-symbol-in-byte-package-save
- fop-symbol-in-package-save
- file)
- (dump-word pname-length file)))
+ (dump-fop* pname-length
+ fop-uninterned-small-symbol-save
+ fop-uninterned-symbol-save
+ file))
+ ;; CMU CL had FOP-SYMBOL-SAVE/FOP-SMALL-SYMBOL-SAVE fops which
+ ;; used the current value of *PACKAGE*. Unfortunately that's
+ ;; broken w.r.t. ANSI Common Lisp semantics, so those are gone
+ ;; from SBCL.
+ ;;((eq pkg *package*)
+ ;; (dump-fop* pname-length
+ ;; fop-small-symbol-save
+ ;; fop-symbol-save file))
+ ((eq pkg sb!int:*cl-package*)
+ (dump-fop* pname-length
+ fop-lisp-small-symbol-save
+ fop-lisp-symbol-save
+ file))
+ ((eq pkg sb!int:*keyword-package*)
+ (dump-fop* pname-length
+ fop-keyword-small-symbol-save
+ fop-keyword-symbol-save
+ file))
+ ((< pname-length 256)
+ (dump-fop* (dump-package pkg file)
+ fop-small-symbol-in-byte-package-save
+ fop-small-symbol-in-package-save
+ file)
+ (dump-byte pname-length file))
+ (t
+ (dump-fop* (dump-package pkg file)
+ fop-symbol-in-byte-package-save
+ fop-symbol-in-package-save
+ file)
+ (dump-word pname-length file)))
#+sb-xc-host (dump-base-chars-of-string pname file)
#-sb-xc-host (#!+sb-unicode dump-characters-of-string
(unless *cold-load-dump*
(setf (gethash s (fasl-output-eq-table file))
- (fasl-output-table-free file)))
+ (fasl-output-table-free file)))
(incf (fasl-output-table-free file)))
(defun dump-segment (segment code-length fasl-output)
(declare (type sb!assem:segment segment)
- (type fasl-output fasl-output))
+ (type fasl-output fasl-output))
(let* ((stream (fasl-output-stream fasl-output))
- (n-written (write-segment-contents segment stream)))
+ (n-written (write-segment-contents segment stream)))
;; In CMU CL there was no enforced connection between the CODE-LENGTH
;; argument and the number of bytes actually written. I added this
;; assertion while trying to debug portable genesis. -- WHN 19990902
(declare (list fixups) (type fasl-output fasl-output))
(dolist (note fixups)
(let* ((kind (fixup-note-kind note))
- (fixup (fixup-note-fixup note))
- (position (fixup-note-position note))
- (name (fixup-name fixup))
- (flavor (fixup-flavor fixup)))
+ (fixup (fixup-note-fixup note))
+ (position (fixup-note-position note))
+ (name (fixup-name fixup))
+ (flavor (fixup-flavor fixup)))
(dump-fop 'fop-normal-load fasl-output)
(let ((*cold-load-dump* t))
- (dump-object kind fasl-output))
+ (dump-object kind fasl-output))
(dump-fop 'fop-maybe-cold-load fasl-output)
;; Depending on the flavor, we may have various kinds of
;; noise before the position.
(ecase flavor
- (:assembly-routine
- (aver (symbolp name))
- (dump-fop 'fop-normal-load fasl-output)
- (let ((*cold-load-dump* t))
- (dump-object name fasl-output))
- (dump-fop 'fop-maybe-cold-load fasl-output)
- (dump-fop 'fop-assembler-fixup fasl-output))
- ((:foreign :foreign-dataref)
- (aver (stringp name))
- (ecase flavor
- (:foreign
- (dump-fop 'fop-foreign-fixup fasl-output))
- #!+linkage-table
- (:foreign-dataref
- (dump-fop 'fop-foreign-dataref-fixup fasl-output)))
- (let ((len (length name)))
- (aver (< len 256)) ; (limit imposed by fop definition)
- (dump-byte len fasl-output)
- (dotimes (i len)
- (dump-byte (char-code (schar name i)) fasl-output))))
- (:code-object
- (aver (null name))
- (dump-fop 'fop-code-object-fixup fasl-output)))
+ (:assembly-routine
+ (aver (symbolp name))
+ (dump-fop 'fop-normal-load fasl-output)
+ (let ((*cold-load-dump* t))
+ (dump-object name fasl-output))
+ (dump-fop 'fop-maybe-cold-load fasl-output)
+ (dump-fop 'fop-assembler-fixup fasl-output))
+ ((:foreign :foreign-dataref)
+ (aver (stringp name))
+ (ecase flavor
+ (:foreign
+ (dump-fop 'fop-foreign-fixup fasl-output))
+ #!+linkage-table
+ (:foreign-dataref
+ (dump-fop 'fop-foreign-dataref-fixup fasl-output)))
+ (let ((len (length name)))
+ (aver (< len 256)) ; (limit imposed by fop definition)
+ (dump-byte len fasl-output)
+ (dotimes (i len)
+ (dump-byte (char-code (schar name i)) fasl-output))))
+ (:code-object
+ (aver (null name))
+ (dump-fop 'fop-code-object-fixup fasl-output)))
;; No matter what the flavor, we'll always dump the position
(dump-word position fasl-output)))
(values))
;;;
;;; We dump trap objects in any unused slots or forward referenced slots.
(defun dump-code-object (component
- code-segment
- code-length
- trace-table-as-list
- fixups
- fasl-output)
+ code-segment
+ code-length
+ trace-table-as-list
+ fixups
+ fasl-output)
(declare (type component component)
- (list trace-table-as-list)
- (type index code-length)
- (type fasl-output fasl-output))
+ (list trace-table-as-list)
+ (type index code-length)
+ (type fasl-output fasl-output))
(let* ((2comp (component-info component))
- (constants (sb!c::ir2-component-constants 2comp))
- (header-length (length constants))
- (packed-trace-table (pack-trace-table trace-table-as-list))
- (total-length (+ code-length
- (* (length packed-trace-table)
- sb!c::tt-bytes-per-entry))))
+ (constants (sb!c::ir2-component-constants 2comp))
+ (header-length (length constants))
+ (packed-trace-table (pack-trace-table trace-table-as-list))
+ (total-length (+ code-length
+ (* (length packed-trace-table)
+ sb!c::tt-bytes-per-entry))))
(collect ((patches))
;; Dump the constants, noting any :ENTRY constants that have to
;; be patched.
(loop for i from sb!vm:code-constants-offset below header-length do
- (let ((entry (aref constants i)))
- (etypecase entry
- (constant
- (dump-object (sb!c::constant-value entry) fasl-output))
- (cons
- (ecase (car entry)
- (:entry
- (let* ((info (sb!c::leaf-info (cdr entry)))
- (handle (gethash info
- (fasl-output-entry-table
- fasl-output))))
- (declare (type sb!c::entry-info info))
- (cond
- (handle
- (dump-push handle fasl-output))
- (t
- (patches (cons info i))
- (dump-fop 'fop-misc-trap fasl-output)))))
- (:load-time-value
- (dump-push (cdr entry) fasl-output))
- (:fdefinition
- (dump-object (cdr entry) fasl-output)
- (dump-fop 'fop-fdefinition fasl-output))))
- (null
- (dump-fop 'fop-misc-trap fasl-output)))))
+ (let ((entry (aref constants i)))
+ (etypecase entry
+ (constant
+ (dump-object (sb!c::constant-value entry) fasl-output))
+ (cons
+ (ecase (car entry)
+ (:entry
+ (let* ((info (sb!c::leaf-info (cdr entry)))
+ (handle (gethash info
+ (fasl-output-entry-table
+ fasl-output))))
+ (declare (type sb!c::entry-info info))
+ (cond
+ (handle
+ (dump-push handle fasl-output))
+ (t
+ (patches (cons info i))
+ (dump-fop 'fop-misc-trap fasl-output)))))
+ (:load-time-value
+ (dump-push (cdr entry) fasl-output))
+ (:fdefinition
+ (dump-object (cdr entry) fasl-output)
+ (dump-fop 'fop-fdefinition fasl-output))))
+ (null
+ (dump-fop 'fop-misc-trap fasl-output)))))
;; Dump the debug info.
(let ((info (sb!c::debug-info-for-component component))
- (*dump-only-valid-structures* nil))
- (dump-object info fasl-output)
- (let ((info-handle (dump-pop fasl-output)))
- (dump-push info-handle fasl-output)
- (push info-handle (fasl-output-debug-info fasl-output))))
+ (*dump-only-valid-structures* nil))
+ (dump-object info fasl-output)
+ (let ((info-handle (dump-pop fasl-output)))
+ (dump-push info-handle fasl-output)
+ (push info-handle (fasl-output-debug-info fasl-output))))
(let ((num-consts (- header-length sb!vm:code-trace-table-offset-slot)))
- (cond ((and (< num-consts #x100) (< total-length #x10000))
- (dump-fop 'fop-small-code fasl-output)
- (dump-byte num-consts fasl-output)
- (dump-integer-as-n-bytes total-length (/ sb!vm:n-word-bytes 2) fasl-output))
- (t
- (dump-fop 'fop-code fasl-output)
- (dump-word num-consts fasl-output)
- (dump-word total-length fasl-output))))
+ (cond ((and (< num-consts #x100) (< total-length #x10000))
+ (dump-fop 'fop-small-code fasl-output)
+ (dump-byte num-consts fasl-output)
+ (dump-integer-as-n-bytes total-length (/ sb!vm:n-word-bytes 2) fasl-output))
+ (t
+ (dump-fop 'fop-code fasl-output)
+ (dump-word num-consts fasl-output)
+ (dump-word total-length fasl-output))))
;; These two dumps are only ones which contribute to our
;; TOTAL-LENGTH value.
(dump-fop 'fop-sanctify-for-execution fasl-output)
(let ((handle (dump-pop fasl-output)))
- (dolist (patch (patches))
- (push (cons handle (cdr patch))
- (gethash (car patch)
- (fasl-output-patch-table fasl-output))))
- handle))))
+ (dolist (patch (patches))
+ (push (cons handle (cdr patch))
+ (gethash (car patch)
+ (fasl-output-patch-table fasl-output))))
+ handle))))
(defun dump-assembler-routines (code-segment length fixups routines file)
(dump-fop 'fop-assembler-code file)
;;; component.
(defun dump-one-entry (entry code-handle file)
(declare (type sb!c::entry-info entry) (type index code-handle)
- (type fasl-output file))
+ (type fasl-output file))
(let ((name (sb!c::entry-info-name entry)))
(dump-push code-handle file)
(dump-object name file)
;;; Dump the code, constants, etc. for component. We pass in the
;;; assembler fixups, code vector and node info.
(defun fasl-dump-component (component
- code-segment
- code-length
- trace-table
- fixups
- file)
+ code-segment
+ code-length
+ trace-table
+ fixups
+ file)
(declare (type component component) (list trace-table))
(declare (type fasl-output file))
(fasl-validate-structure info file)))
(let ((code-handle (dump-code-object component
- code-segment
- code-length
- trace-table
- fixups
- file))
- (2comp (component-info component)))
+ code-segment
+ code-length
+ trace-table
+ fixups
+ file))
+ (2comp (component-info component)))
(dump-fop 'fop-verify-empty-stack file)
(dolist (entry (sb!c::ir2-component-entries 2comp))
(let ((entry-handle (dump-one-entry entry code-handle file)))
- (setf (gethash entry (fasl-output-entry-table file)) entry-handle)
- (let ((old (gethash entry (fasl-output-patch-table file))))
- (when old
- (dolist (patch old)
- (dump-alter-code-object (car patch)
- (cdr patch)
- entry-handle
- file))
- (remhash entry (fasl-output-patch-table file)))))))
+ (setf (gethash entry (fasl-output-entry-table file)) entry-handle)
+ (let ((old (gethash entry (fasl-output-patch-table file))))
+ (when old
+ (dolist (patch old)
+ (dump-alter-code-object (car patch)
+ (cdr patch)
+ entry-handle
+ file))
+ (remhash entry (fasl-output-patch-table file)))))))
(values))
(defun dump-push-previously-dumped-fun (fun fasl-output)
(declare (type sb!c::clambda fun))
(let ((handle (gethash (sb!c::leaf-info fun)
- (fasl-output-entry-table fasl-output))))
+ (fasl-output-entry-table fasl-output))))
(aver handle)
(dump-push handle fasl-output))
(values))
(dump-push fun-dump-handle fasl-output)
(dump-fop 'fop-fset fasl-output)
(values))
-
+
;;; Compute the correct list of DEBUG-SOURCE structures and backpatch
;;; all of the dumped DEBUG-INFO structures. We clear the
;;; FASL-OUTPUT-DEBUG-INFO, so that subsequent components with
(defun fasl-dump-source-info (info fasl-output)
(declare (type sb!c::source-info info))
(let ((res (sb!c::debug-source-for-info info))
- (*dump-only-valid-structures* nil))
+ (*dump-only-valid-structures* nil))
(dump-object res fasl-output)
(let ((res-handle (dump-pop fasl-output)))
(dolist (info-handle (fasl-output-debug-info fasl-output))
- (dump-push res-handle fasl-output)
- (dump-fop 'fop-structset fasl-output)
- (dump-word info-handle fasl-output)
+ (dump-push res-handle fasl-output)
+ (dump-fop 'fop-structset fasl-output)
+ (dump-word info-handle fasl-output)
;; FIXME: what is this bare `2'? --njf, 2004-08-16
- (dump-word 2 fasl-output))))
+ (dump-word 2 fasl-output))))
(setf (fasl-output-debug-info fasl-output) nil)
(values))
\f
(when *dump-only-valid-structures*
(unless (gethash struct (fasl-output-valid-structures file))
(error "attempt to dump invalid structure:~% ~S~%How did this happen?"
- struct)))
+ struct)))
(note-potential-circularity struct file)
(aver (%instance-ref struct 0))
(do* ((length (%instance-length struct))
- (ntagged (- length (layout-n-untagged-slots (%instance-ref struct 0))))
- (circ (fasl-output-circularity-table file))
- ;; last slot first on the stack, so that the layout is on top:
- (index (1- length) (1- index)))
+ (ntagged (- length (layout-n-untagged-slots (%instance-ref struct 0))))
+ (circ (fasl-output-circularity-table file))
+ ;; last slot first on the stack, so that the layout is on top:
+ (index (1- length) (1- index)))
((minusp index)
(dump-fop* length fop-small-struct fop-struct file))
(let* ((obj (if (>= index ntagged)
- (%raw-instance-ref/word struct (- length index 1))
- (%instance-ref struct index)))
- (ref (gethash obj circ)))
+ (%raw-instance-ref/word struct (- length index 1))
+ (%instance-ref struct index)))
+ (ref (gethash obj circ)))
(cond (ref
- (aver (not (zerop index)))
- (push (make-circularity :type :struct-set
- :object struct
- :index index
- :value obj
- :enclosing-object ref)
- *circularities-detected*)
- (sub-dump-object nil file))
- (t
- (sub-dump-object obj file))))))
+ (aver (not (zerop index)))
+ (push (make-circularity :type :struct-set
+ :object struct
+ :index index
+ :value obj
+ :enclosing-object ref)
+ *circularities-detected*)
+ (sub-dump-object nil file))
+ (t
+ (sub-dump-object obj file))))))
(defun dump-layout (obj file)
(when (layout-invalid obj)
(compiler-error "attempt to dump reference to obsolete class: ~S"
- (layout-classoid obj)))
+ (layout-classoid obj)))
(let ((name (classoid-name (layout-classoid obj))))
(unless name
(compiler-error "dumping anonymous layout: ~S" obj))
(defvar *object-id-counter* 0)
(defun new-object-id ()
(prog1
- *object-id-counter*
+ *object-id-counter*
(incf *object-id-counter*))))
\f
;;;; miscellaneous utilities
;;; benefit of the compiler, but it's sometimes called from stuff like
;;; type-defining code which isn't logically part of the compiler.
(declaim (ftype (function ((or symbol cons) keyword) (values))
- note-name-defined))
+ note-name-defined))
(defun note-name-defined (name kind)
;; We do this BOUNDP check because this function can be called when
;; not in a compilation unit (as when loading top level forms).
(when (boundp '*undefined-warnings*)
(setq *undefined-warnings*
- (delete-if (lambda (x)
- (and (equal (undefined-warning-name x) name)
- (eq (undefined-warning-kind x) kind)))
- *undefined-warnings*)))
+ (delete-if (lambda (x)
+ (and (equal (undefined-warning-name x) name)
+ (eq (undefined-warning-kind x) kind)))
+ *undefined-warnings*)))
(values))
;;; to be called when a variable is lexically bound
(let ((2comp (component-info component)))
(dolist (fun (component-lambdas component))
(when (xep-p fun)
- (let ((info (or (leaf-info fun)
- (setf (leaf-info fun) (make-entry-info)))))
- (compute-entry-info fun info)
- (push info (ir2-component-entries 2comp))))))
+ (let ((info (or (leaf-info fun)
+ (setf (leaf-info fun) (make-entry-info)))))
+ (compute-entry-info fun info)
+ (push info (ir2-component-entries 2comp))))))
(select-component-format component)
(values))
(defun compute-entry-info (fun info)
(declare (type clambda fun) (type entry-info info))
(let ((bind (lambda-bind fun))
- (internal-fun (functional-entry-fun fun)))
+ (internal-fun (functional-entry-fun fun)))
(setf (entry-info-closure-tn info)
(if (physenv-closure (lambda-physenv fun))
(make-normal-tn *backend-t-primitive-type*)
nil))
(setf (entry-info-offset info) (gen-label))
(setf (entry-info-name info)
- (leaf-debug-name internal-fun))
+ (leaf-debug-name internal-fun))
(when (policy bind (>= debug 1))
(let ((args (functional-arg-documentation internal-fun)))
(aver (not (eq args :unspecified)))
(let ((res nil))
(dolist (lambda (component-lambdas component))
(case (functional-kind lambda)
- (:external
- (unless (lambda-has-external-references-p lambda)
- (let* ((ef (functional-entry-fun lambda))
- (new (make-functional
- :kind :toplevel-xep
- :info (leaf-info lambda)
- :%source-name (functional-%source-name ef)
- :%debug-name (functional-%debug-name ef)
- :lexenv (make-null-lexenv)))
- (closure (physenv-closure
- (lambda-physenv (main-entry ef)))))
- (dolist (ref (leaf-refs lambda))
- (let ((ref-component (node-component ref)))
- (cond ((eq ref-component component))
- ((or (not (component-toplevelish-p ref-component))
- closure)
- (setq res t))
- (t
- (setf (ref-leaf ref) new)
- (push ref (leaf-refs new))
+ (:external
+ (unless (lambda-has-external-references-p lambda)
+ (let* ((ef (functional-entry-fun lambda))
+ (new (make-functional
+ :kind :toplevel-xep
+ :info (leaf-info lambda)
+ :%source-name (functional-%source-name ef)
+ :%debug-name (functional-%debug-name ef)
+ :lexenv (make-null-lexenv)))
+ (closure (physenv-closure
+ (lambda-physenv (main-entry ef)))))
+ (dolist (ref (leaf-refs lambda))
+ (let ((ref-component (node-component ref)))
+ (cond ((eq ref-component component))
+ ((or (not (component-toplevelish-p ref-component))
+ closure)
+ (setq res t))
+ (t
+ (setf (ref-leaf ref) new)
+ (push ref (leaf-refs new))
(setf (leaf-refs lambda)
(delq ref (leaf-refs lambda))))))))))
- (:toplevel
- (setq res t))))
+ (:toplevel
+ (setq res t))))
res))
(!cold-init-forms
(map 'nil
(lambda (saetp)
- (setf (sb!vm:saetp-ctype saetp)
- (specifier-type (sb!vm:saetp-specifier saetp))))
+ (setf (sb!vm:saetp-ctype saetp)
+ (specifier-type (sb!vm:saetp-specifier saetp))))
sb!vm:*specialized-array-element-type-properties*))
(!defun-from-collected-cold-init-forms !fixup-type-cold-init)
\ No newline at end of file
;;; a fixup of some kind
(defstruct (fixup
- (:constructor make-fixup (name flavor &optional offset))
- (:copier nil))
+ (:constructor make-fixup (name flavor &optional offset))
+ (:copier nil))
;; the name and flavor of the fixup. The assembler makes no
;; assumptions about the contents of these fields; their semantics
;; are imposed by the dumper.
offset)
(defstruct (fixup-note
- (:constructor make-fixup-note (kind fixup position))
- (:copier nil))
+ (:constructor make-fixup-note (kind fixup position))
+ (:copier nil))
kind
fixup
position)
;;; they find themselves trying to deal with a fixup.
(defun note-fixup (segment kind fixup)
(sb!assem:emit-back-patch segment
- 0
- (lambda (segment posn)
- (declare (ignore segment))
- ;; Why use EMIT-BACK-PATCH to cause this PUSH to
- ;; be done later, instead of just doing it now?
- ;; I'm not sure. Perhaps there's some concern
- ;; that POSN isn't known accurately now? Perhaps
- ;; there's a desire for all fixing up to go
- ;; through EMIT-BACK-PATCH whether it needs to or
- ;; not? -- WHN 19990905
- #!+sb-show
- (when *show-fixups-being-pushed-p*
- (/show "PUSHING FIXUP" kind fixup posn))
- (push (make-fixup-note kind fixup posn) *fixup-notes*)))
+ 0
+ (lambda (segment posn)
+ (declare (ignore segment))
+ ;; Why use EMIT-BACK-PATCH to cause this PUSH to
+ ;; be done later, instead of just doing it now?
+ ;; I'm not sure. Perhaps there's some concern
+ ;; that POSN isn't known accurately now? Perhaps
+ ;; there's a desire for all fixing up to go
+ ;; through EMIT-BACK-PATCH whether it needs to or
+ ;; not? -- WHN 19990905
+ #!+sb-show
+ (when *show-fixups-being-pushed-p*
+ (/show "PUSHING FIXUP" kind fixup posn))
+ (push (make-fixup-note kind fixup posn) *fixup-notes*)))
(values))
;;; RANDOM
(macrolet ((frob (fun type)
- `(deftransform random ((num &optional state)
- (,type &optional *) *)
- "Use inline float operations."
- '(,fun num (or state *random-state*)))))
+ `(deftransform random ((num &optional state)
+ (,type &optional *) *)
+ "Use inline float operations."
+ '(,fun num (or state *random-state*)))))
(frob %random-single-float single-float)
(frob %random-double-float double-float))
;;; through the code this way. It would be nice to move this into the
;;; same file as the other RANDOM definitions.
(deftransform random ((num &optional state)
- ((integer 1 #.(expt 2 sb!vm::n-word-bits)) &optional *))
+ ((integer 1 #.(expt 2 sb!vm::n-word-bits)) &optional *))
;; FIXME: I almost conditionalized this as #!+sb-doc. Find some way
;; of automatically finding #!+sb-doc in proximity to DEFTRANSFORM
;; to let me scan for places that I made this mistake and didn't
;; catch myself.
"use inline (UNSIGNED-BYTE 32) operations"
(let ((type (lvar-type num))
- (limit (expt 2 sb!vm::n-word-bits))
- (random-chunk (ecase sb!vm::n-word-bits
- (32 'random-chunk)
- (64 'sb!kernel::big-random-chunk))))
+ (limit (expt 2 sb!vm::n-word-bits))
+ (random-chunk (ecase sb!vm::n-word-bits
+ (32 'random-chunk)
+ (64 'sb!kernel::big-random-chunk))))
(if (numeric-type-p type)
(let ((num-high (numeric-type-high (lvar-type num))))
(aver num-high)
(if (= num-high limit)
`(,random-chunk (or state *random-state*))
#!-(or x86 x86-64)
- `(rem (,random-chunk (or state *random-state*)) num)
+ `(rem (,random-chunk (or state *random-state*)) num)
#!+(or x86 x86-64)
;; Use multiplication, which is faster.
`(values (sb!bignum::%multiply
((> num-high random-fixnum-max)
(give-up-ir1-transform
"The range is too large to ensure an accurate result."))
- #!+(or x86 x86-64)
+ #!+(or x86 x86-64)
((< num-high limit)
`(values (sb!bignum::%multiply
(,random-chunk (or state *random-state*))
(movable foldable flushable))
(deftransform float-sign ((float &optional float2)
- (single-float &optional single-float) *)
+ (single-float &optional single-float) *)
(if float2
(let ((temp (gensym)))
- `(let ((,temp (abs float2)))
- (if (minusp (single-float-bits float)) (- ,temp) ,temp)))
+ `(let ((,temp (abs float2)))
+ (if (minusp (single-float-bits float)) (- ,temp) ,temp)))
'(if (minusp (single-float-bits float)) -1f0 1f0)))
(deftransform float-sign ((float &optional float2)
- (double-float &optional double-float) *)
+ (double-float &optional double-float) *)
(if float2
(let ((temp (gensym)))
- `(let ((,temp (abs float2)))
- (if (minusp (double-float-high-bits float)) (- ,temp) ,temp)))
+ `(let ((,temp (abs float2)))
+ (if (minusp (double-float-high-bits float)) (- ,temp) ,temp)))
'(if (minusp (double-float-high-bits float)) -1d0 1d0)))
\f
;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, and SCALE-FLOAT
(deftransform scale-float ((f ex) (single-float *) *)
(if (and #!+x86 t #!-x86 nil
- (csubtypep (lvar-type ex)
- (specifier-type '(signed-byte 32))))
+ (csubtypep (lvar-type ex)
+ (specifier-type '(signed-byte 32))))
'(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)
'(scale-single-float f ex)))
(deftransform scale-float ((f ex) (double-float *) *)
(if (and #!+x86 t #!-x86 nil
- (csubtypep (lvar-type ex)
- (specifier-type '(signed-byte 32))))
+ (csubtypep (lvar-type ex)
+ (specifier-type '(signed-byte 32))))
'(%scalbn f ex)
'(scale-double-float f ex)))
(defun scale-float-derive-type-aux (f ex same-arg)
(declare (ignore same-arg))
(flet ((scale-bound (x n)
- ;; We need to be a bit careful here and catch any overflows
- ;; that might occur. We can ignore underflows which become
- ;; zeros.
- (set-bound
- (handler-case
- (scale-float (type-bound-number x) n)
- (floating-point-overflow ()
- nil))
- (consp x))))
+ ;; We need to be a bit careful here and catch any overflows
+ ;; that might occur. We can ignore underflows which become
+ ;; zeros.
+ (set-bound
+ (handler-case
+ (scale-float (type-bound-number x) n)
+ (floating-point-overflow ()
+ nil))
+ (consp x))))
(when (and (numeric-type-p f) (numeric-type-p ex))
(let ((f-lo (numeric-type-low f))
- (f-hi (numeric-type-high f))
- (ex-lo (numeric-type-low ex))
- (ex-hi (numeric-type-high ex))
- (new-lo nil)
- (new-hi nil))
- (when f-hi
- (if (< (float-sign (type-bound-number f-hi)) 0.0)
- (when ex-lo
- (setf new-hi (scale-bound f-hi ex-lo)))
- (when ex-hi
- (setf new-hi (scale-bound f-hi ex-hi)))))
- (when f-lo
- (if (< (float-sign (type-bound-number f-lo)) 0.0)
- (when ex-hi
- (setf new-lo (scale-bound f-lo ex-hi)))
- (when ex-lo
- (setf new-lo (scale-bound f-lo ex-lo)))))
- (make-numeric-type :class (numeric-type-class f)
- :format (numeric-type-format f)
- :complexp :real
- :low new-lo
- :high new-hi)))))
+ (f-hi (numeric-type-high f))
+ (ex-lo (numeric-type-low ex))
+ (ex-hi (numeric-type-high ex))
+ (new-lo nil)
+ (new-hi nil))
+ (when f-hi
+ (if (< (float-sign (type-bound-number f-hi)) 0.0)
+ (when ex-lo
+ (setf new-hi (scale-bound f-hi ex-lo)))
+ (when ex-hi
+ (setf new-hi (scale-bound f-hi ex-hi)))))
+ (when f-lo
+ (if (< (float-sign (type-bound-number f-lo)) 0.0)
+ (when ex-hi
+ (setf new-lo (scale-bound f-lo ex-hi)))
+ (when ex-lo
+ (setf new-lo (scale-bound f-lo ex-lo)))))
+ (make-numeric-type :class (numeric-type-class f)
+ :format (numeric-type-format f)
+ :complexp :real
+ :low new-lo
+ :high new-hi)))))
(defoptimizer (scale-single-float derive-type) ((f ex))
(two-arg-derive-type f ex #'scale-float-derive-type-aux
- #'scale-single-float t))
+ #'scale-single-float t))
(defoptimizer (scale-double-float derive-type) ((f ex))
(two-arg-derive-type f ex #'scale-float-derive-type-aux
- #'scale-double-float t))
+ #'scale-double-float t))
;;; DEFOPTIMIZERs for %SINGLE-FLOAT and %DOUBLE-FLOAT. This makes the
;;; FLOAT function return the correct ranges if the input has some
(macrolet
((frob (fun type)
(let ((aux-name (symbolicate fun "-DERIVE-TYPE-AUX")))
- `(progn
- (defun ,aux-name (num)
- ;; When converting a number to a float, the limits are
- ;; the same.
- (let* ((lo (bound-func (lambda (x)
- (coerce x ',type))
- (numeric-type-low num)))
- (hi (bound-func (lambda (x)
- (coerce x ',type))
- (numeric-type-high num))))
- (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
-
- (defoptimizer (,fun derive-type) ((num))
- (one-arg-derive-type num #',aux-name #',fun))))))
+ `(progn
+ (defun ,aux-name (num)
+ ;; When converting a number to a float, the limits are
+ ;; the same.
+ (let* ((lo (bound-func (lambda (x)
+ (coerce x ',type))
+ (numeric-type-low num)))
+ (hi (bound-func (lambda (x)
+ (coerce x ',type))
+ (numeric-type-high num))))
+ (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
+
+ (defoptimizer (,fun derive-type) ((num))
+ (one-arg-derive-type num #',aux-name #',fun))))))
(frob %single-float single-float)
(frob %double-float double-float))
-) ; PROGN
+) ; PROGN
\f
;;;; float contagion
(dolist (x '(= < > + * / -))
(%deftransform x '(function (single-float double-float) *)
- #'float-contagion-arg1)
+ #'float-contagion-arg1)
(%deftransform x '(function (double-float single-float) *)
- #'float-contagion-arg2))
+ #'float-contagion-arg2))
;;; Prevent ZEROP, PLUSP, and MINUSP from losing horribly. We can't in
;;; general float rational args to comparison, since Common Lisp
;;; do it for any rational that has a precise representation as a
;;; float (such as 0).
(macrolet ((frob (op)
- `(deftransform ,op ((x y) (float rational) *)
- "open-code FLOAT to RATIONAL comparison"
- (unless (constant-lvar-p y)
- (give-up-ir1-transform
- "The RATIONAL value isn't known at compile time."))
- (let ((val (lvar-value y)))
- (unless (eql (rational (float val)) val)
- (give-up-ir1-transform
- "~S doesn't have a precise float representation."
- val)))
- `(,',op x (float y x)))))
+ `(deftransform ,op ((x y) (float rational) *)
+ "open-code FLOAT to RATIONAL comparison"
+ (unless (constant-lvar-p y)
+ (give-up-ir1-transform
+ "The RATIONAL value isn't known at compile time."))
+ (let ((val (lvar-value y)))
+ (unless (eql (rational (float val)) val)
+ (give-up-ir1-transform
+ "~S doesn't have a precise float representation."
+ val)))
+ `(,',op x (float y x)))))
(frob <)
(frob >)
(frob =))
;;; appropriate domain.
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(dolist (stuff '((asin (real -1.0 1.0))
- (acos (real -1.0 1.0))
- (acosh (real 1.0))
- (atanh (real -1.0 1.0))
- (sqrt (real 0.0))))
+ (acos (real -1.0 1.0))
+ (acosh (real 1.0))
+ (atanh (real -1.0 1.0))
+ (sqrt (real 0.0))))
(destructuring-bind (name type) stuff
(let ((type (specifier-type type)))
(setf (fun-info-derive-type (fun-info-or-lose name))
- (lambda (call)
- (declare (type combination call))
- (when (csubtypep (lvar-type
- (first (combination-args call)))
- type)
- (specifier-type 'float)))))))
+ (lambda (call)
+ (declare (type combination call))
+ (when (csubtypep (lvar-type
+ (first (combination-args call)))
+ type)
+ (specifier-type 'float)))))))
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (log derive-type) ((x &optional y))
(when (and (csubtypep (lvar-type x)
- (specifier-type '(real 0.0)))
- (or (null y)
- (csubtypep (lvar-type y)
- (specifier-type '(real 0.0)))))
+ (specifier-type '(real 0.0)))
+ (or (null y)
+ (csubtypep (lvar-type y)
+ (specifier-type '(real 0.0)))))
(specifier-type 'float)))
\f
;;;; irrational transforms
(defknown (%tan %sinh %asinh %atanh %log %logb %log10 %tan-quick)
- (double-float) double-float
+ (double-float) double-float
(movable foldable flushable))
(defknown (%sin %cos %tanh %sin-quick %cos-quick)
(defknown (%asin %atan)
(double-float)
(double-float #.(coerce (- (/ pi 2)) 'double-float)
- #.(coerce (/ pi 2) 'double-float))
+ #.(coerce (/ pi 2) 'double-float))
(movable foldable flushable))
(defknown (%acos)
(defknown (%atan2)
(double-float double-float)
(double-float #.(coerce (- pi) 'double-float)
- #.(coerce pi 'double-float))
+ #.(coerce pi 'double-float))
(movable foldable flushable))
(defknown (%scalb)
(deftransform abs ((x) ((complex single-float)) single-float)
'(coerce (%hypot (coerce (realpart x) 'double-float)
- (coerce (imagpart x) 'double-float))
- 'single-float))
+ (coerce (imagpart x) 'double-float))
+ 'single-float))
(deftransform phase ((x) ((complex double-float)) double-float)
'(%atan2 (imagpart x) (realpart x)))
(deftransform phase ((x) ((complex single-float)) single-float)
'(coerce (%atan2 (coerce (imagpart x) 'double-float)
- (coerce (realpart x) 'double-float))
- 'single-float))
+ (coerce (realpart x) 'double-float))
+ 'single-float))
(deftransform phase ((x) ((float)) float)
'(if (minusp (float-sign x))
(defun coerce-numeric-bound (bound type)
(when bound
(if (consp bound)
- (list (coerce (car bound) type))
- (coerce bound type))))
+ (list (coerce (car bound) type))
+ (coerce bound type))))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun complex-float-type (arg)
(declare (type numeric-type arg))
(let* ((format (case (numeric-type-class arg)
- ((integer rational) 'single-float)
- (t (numeric-type-format arg))))
- (float-type (or format 'float)))
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (float-type (or format 'float)))
(specifier-type `(complex ,float-type))))
;;; Compute a specifier like '(OR FLOAT (COMPLEX FLOAT)), except float
(defun float-or-complex-float-type (arg &optional lo hi)
(declare (type numeric-type arg))
(let* ((format (case (numeric-type-class arg)
- ((integer rational) 'single-float)
- (t (numeric-type-format arg))))
- (float-type (or format 'float))
- (lo (coerce-numeric-bound lo float-type))
- (hi (coerce-numeric-bound hi float-type)))
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (float-type (or format 'float))
+ (lo (coerce-numeric-bound lo float-type))
+ (hi (coerce-numeric-bound hi float-type)))
(specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
- (complex ,float-type)))))
+ (complex ,float-type)))))
) ; PROGN
;; the host does not have long floats, then setting *R-D-F-F* to
;; LONG-FLOAT doesn't actually buy us anything. FIXME.
(setf *read-default-float-format*
- #!+long-float 'long-float #!-long-float 'double-float))
+ #!+long-float 'long-float #!-long-float 'double-float))
;;; Test whether the numeric-type ARG is within in domain specified by
;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
;;; be distinct.
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun domain-subtypep (arg domain-low domain-high)
(declare (type numeric-type arg)
- (type (or real null) domain-low domain-high))
+ (type (or real null) domain-low domain-high))
(let* ((arg-lo (numeric-type-low arg))
- (arg-lo-val (type-bound-number arg-lo))
- (arg-hi (numeric-type-high arg))
- (arg-hi-val (type-bound-number arg-hi)))
+ (arg-lo-val (type-bound-number arg-lo))
+ (arg-hi (numeric-type-high arg))
+ (arg-hi-val (type-bound-number arg-hi)))
;; Check that the ARG bounds are correctly canonicalized.
(when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
- (minusp (float-sign arg-lo-val)))
+ (minusp (float-sign arg-lo-val)))
(compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo)
(setq arg-lo 0e0 arg-lo-val arg-lo))
(when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
- (plusp (float-sign arg-hi-val)))
+ (plusp (float-sign arg-hi-val)))
(compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi)
(setq arg-hi (ecase *read-default-float-format*
(double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
#!+long-float
(long-float (load-time-value (make-unportable-float :long-float-negative-zero))))
- arg-hi-val arg-hi))
+ arg-hi-val arg-hi))
(flet ((fp-neg-zero-p (f) ; Is F -0.0?
- (and (floatp f) (zerop f) (minusp (float-sign f))))
- (fp-pos-zero-p (f) ; Is F +0.0?
- (and (floatp f) (zerop f) (plusp (float-sign f)))))
+ (and (floatp f) (zerop f) (minusp (float-sign f))))
+ (fp-pos-zero-p (f) ; Is F +0.0?
+ (and (floatp f) (zerop f) (plusp (float-sign f)))))
(and (or (null domain-low)
(and arg-lo (>= arg-lo-val domain-low)
(not (and (fp-pos-zero-p domain-low)
- (fp-neg-zero-p arg-lo)))))
+ (fp-neg-zero-p arg-lo)))))
(or (null domain-high)
(and arg-hi (<= arg-hi-val domain-high)
(not (and (fp-neg-zero-p domain-high)
- (fp-pos-zero-p arg-hi)))))))))
+ (fp-pos-zero-p arg-hi)))))))))
(eval-when (:compile-toplevel :execute)
(setf *read-default-float-format* 'single-float))
;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we
;;; can't compute the bounds using FCN.
(defun elfun-derive-type-simple (arg fcn domain-low domain-high
- default-low default-high
- &optional (increasingp t))
+ default-low default-high
+ &optional (increasingp t))
(declare (type (or null real) domain-low domain-high))
(etypecase arg
(numeric-type
(cond ((eq (numeric-type-complexp arg) :complex)
- (complex-float-type arg))
- ((numeric-type-real-p arg)
- ;; The argument is real, so let's find the intersection
- ;; between the argument and the domain of the function.
- ;; We compute the bounds on the intersection, and for
- ;; everything else, we return a complex number of the
- ;; appropriate type.
- (multiple-value-bind (intersection difference)
- (interval-intersection/difference (numeric-type->interval arg)
- (make-interval
- :low domain-low
- :high domain-high))
- (cond
- (intersection
- ;; Process the intersection.
- (let* ((low (interval-low intersection))
- (high (interval-high intersection))
- (res-lo (or (bound-func fcn (if increasingp low high))
- default-low))
- (res-hi (or (bound-func fcn (if increasingp high low))
- default-high))
- (format (case (numeric-type-class arg)
- ((integer rational) 'single-float)
- (t (numeric-type-format arg))))
- (bound-type (or format 'float))
- (result-type
- (make-numeric-type
- :class 'float
- :format format
- :low (coerce-numeric-bound res-lo bound-type)
- :high (coerce-numeric-bound res-hi bound-type))))
- ;; If the ARG is a subset of the domain, we don't
- ;; have to worry about the difference, because that
- ;; can't occur.
- (if (or (null difference)
- ;; Check whether the arg is within the domain.
- (domain-subtypep arg domain-low domain-high))
- result-type
- (list result-type
- (specifier-type `(complex ,bound-type))))))
- (t
- ;; No intersection so the result must be purely complex.
- (complex-float-type arg)))))
- (t
- (float-or-complex-float-type arg default-low default-high))))))
+ (complex-float-type arg))
+ ((numeric-type-real-p arg)
+ ;; The argument is real, so let's find the intersection
+ ;; between the argument and the domain of the function.
+ ;; We compute the bounds on the intersection, and for
+ ;; everything else, we return a complex number of the
+ ;; appropriate type.
+ (multiple-value-bind (intersection difference)
+ (interval-intersection/difference (numeric-type->interval arg)
+ (make-interval
+ :low domain-low
+ :high domain-high))
+ (cond
+ (intersection
+ ;; Process the intersection.
+ (let* ((low (interval-low intersection))
+ (high (interval-high intersection))
+ (res-lo (or (bound-func fcn (if increasingp low high))
+ default-low))
+ (res-hi (or (bound-func fcn (if increasingp high low))
+ default-high))
+ (format (case (numeric-type-class arg)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (bound-type (or format 'float))
+ (result-type
+ (make-numeric-type
+ :class 'float
+ :format format
+ :low (coerce-numeric-bound res-lo bound-type)
+ :high (coerce-numeric-bound res-hi bound-type))))
+ ;; If the ARG is a subset of the domain, we don't
+ ;; have to worry about the difference, because that
+ ;; can't occur.
+ (if (or (null difference)
+ ;; Check whether the arg is within the domain.
+ (domain-subtypep arg domain-low domain-high))
+ result-type
+ (list result-type
+ (specifier-type `(complex ,bound-type))))))
+ (t
+ ;; No intersection so the result must be purely complex.
+ (complex-float-type arg)))))
+ (t
+ (float-or-complex-float-type arg default-low default-high))))))
(macrolet
((frob (name domain-low domain-high def-low-bnd def-high-bnd
- &key (increasingp t))
+ &key (increasingp t))
(let ((num (gensym)))
- `(defoptimizer (,name derive-type) ((,num))
- (one-arg-derive-type
- ,num
- (lambda (arg)
- (elfun-derive-type-simple arg #',name
- ,domain-low ,domain-high
- ,def-low-bnd ,def-high-bnd
- ,increasingp))
- #',name)))))
+ `(defoptimizer (,name derive-type) ((,num))
+ (one-arg-derive-type
+ ,num
+ (lambda (arg)
+ (elfun-derive-type-simple arg #',name
+ ,domain-low ,domain-high
+ ,def-low-bnd ,def-high-bnd
+ ,increasingp))
+ #',name)))))
;; These functions are easy because they are defined for the whole
;; real line.
(frob exp nil nil 0 nil)
;; obviously non-negative. We just have to be careful for
;; infinite bounds (given by nil).
(let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
- (type-bound-number (sb!c::interval-low y))))
- (hi (safe-expt (type-bound-number (sb!c::interval-high x))
- (type-bound-number (sb!c::interval-high y)))))
+ (type-bound-number (sb!c::interval-low y))))
+ (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-high y)))))
(list (sb!c::make-interval :low (or lo 1) :high hi))))
(-
;; Y is negative and log x >= 0. The range of exp(y * log(x)) is
;; obviously [0, 1]. However, underflow (nil) means 0 is the
;; result.
(let ((lo (safe-expt (type-bound-number (sb!c::interval-high x))
- (type-bound-number (sb!c::interval-low y))))
- (hi (safe-expt (type-bound-number (sb!c::interval-low x))
- (type-bound-number (sb!c::interval-high y)))))
+ (type-bound-number (sb!c::interval-low y))))
+ (hi (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-high y)))))
(list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
(t
;; Split the interval in half.
(destructuring-bind (y- y+)
- (sb!c::interval-split 0 y t)
+ (sb!c::interval-split 0 y t)
(list (interval-expt-> x y-)
- (interval-expt-> x y+))))))
+ (interval-expt-> x y+))))))
;;; Handle the case when x <= 1
(defun interval-expt-< (x y)
;; The case of 0 <= x <= 1 is easy
(case (sb!c::interval-range-info y)
(+
- ;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
- ;; obviously [0, 1]. We just have to be careful for infinite bounds
- ;; (given by nil).
- (let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
- (type-bound-number (sb!c::interval-high y))))
- (hi (safe-expt (type-bound-number (sb!c::interval-high x))
- (type-bound-number (sb!c::interval-low y)))))
- (list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
+ ;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
+ ;; obviously [0, 1]. We just have to be careful for infinite bounds
+ ;; (given by nil).
+ (let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-high y))))
+ (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-low y)))))
+ (list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
(-
- ;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
- ;; obviously [1, inf].
- (let ((hi (safe-expt (type-bound-number (sb!c::interval-low x))
- (type-bound-number (sb!c::interval-low y))))
- (lo (safe-expt (type-bound-number (sb!c::interval-high x))
- (type-bound-number (sb!c::interval-high y)))))
- (list (sb!c::make-interval :low (or lo 1) :high hi))))
+ ;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
+ ;; obviously [1, inf].
+ (let ((hi (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-low y))))
+ (lo (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-high y)))))
+ (list (sb!c::make-interval :low (or lo 1) :high hi))))
(t
- ;; Split the interval in half
- (destructuring-bind (y- y+)
- (sb!c::interval-split 0 y t)
- (list (interval-expt-< x y-)
- (interval-expt-< x y+))))))
+ ;; Split the interval in half
+ (destructuring-bind (y- y+)
+ (sb!c::interval-split 0 y t)
+ (list (interval-expt-< x y-)
+ (interval-expt-< x y+))))))
(-
;; The case where x <= 0. Y MUST be an INTEGER for this to work!
;; The calling function must insure this! For now we'll just
(list (sb!c::make-interval :low nil :high nil)))
(t
(destructuring-bind (neg pos)
- (interval-split 0 x t t)
+ (interval-split 0 x t t)
(list (interval-expt-< neg y)
- (interval-expt-< pos y))))))
+ (interval-expt-< pos y))))))
;;; Compute bounds for (expt x y).
(defun interval-expt (x y)
(case (interval-range-info x 1)
(+
;; X >= 1
- (interval-expt-> x y))
+ (interval-expt-> x y))
(-
;; X <= 1
(interval-expt-< x y))
(t
(destructuring-bind (left right)
- (interval-split 1 x t t)
+ (interval-split 1 x t t)
(list (interval-expt left y)
- (interval-expt right y))))))
+ (interval-expt right y))))))
(defun fixup-interval-expt (bnd x-int y-int x-type y-type)
(declare (ignore x-int))
;; Figure out what the return type should be, given the argument
;; types and bounds and the result type and bounds.
(cond ((csubtypep x-type (specifier-type 'integer))
- ;; an integer to some power
- (case (numeric-type-class y-type)
- (integer
- ;; Positive integer to an integer power is either an
- ;; integer or a rational.
- (let ((lo (or (interval-low bnd) '*))
- (hi (or (interval-high bnd) '*)))
- (if (and (interval-low y-int)
- (>= (type-bound-number (interval-low y-int)) 0))
- (specifier-type `(integer ,lo ,hi))
- (specifier-type `(rational ,lo ,hi)))))
- (rational
- ;; Positive integer to rational power is either a rational
- ;; or a single-float.
- (let* ((lo (interval-low bnd))
- (hi (interval-high bnd))
- (int-lo (if lo
- (floor (type-bound-number lo))
- '*))
- (int-hi (if hi
- (ceiling (type-bound-number hi))
- '*))
- (f-lo (if lo
- (bound-func #'float lo)
- '*))
- (f-hi (if hi
- (bound-func #'float hi)
- '*)))
- (specifier-type `(or (rational ,int-lo ,int-hi)
- (single-float ,f-lo, f-hi)))))
- (float
- ;; A positive integer to a float power is a float.
- (modified-numeric-type y-type
- :low (interval-low bnd)
- :high (interval-high bnd)))
- (t
- ;; A positive integer to a number is a number (for now).
- (specifier-type 'number))))
- ((csubtypep x-type (specifier-type 'rational))
- ;; a rational to some power
- (case (numeric-type-class y-type)
- (integer
- ;; A positive rational to an integer power is always a rational.
- (specifier-type `(rational ,(or (interval-low bnd) '*)
- ,(or (interval-high bnd) '*))))
- (rational
- ;; A positive rational to rational power is either a rational
- ;; or a single-float.
- (let* ((lo (interval-low bnd))
- (hi (interval-high bnd))
- (int-lo (if lo
- (floor (type-bound-number lo))
- '*))
- (int-hi (if hi
- (ceiling (type-bound-number hi))
- '*))
- (f-lo (if lo
- (bound-func #'float lo)
- '*))
- (f-hi (if hi
- (bound-func #'float hi)
- '*)))
- (specifier-type `(or (rational ,int-lo ,int-hi)
- (single-float ,f-lo, f-hi)))))
- (float
- ;; A positive rational to a float power is a float.
- (modified-numeric-type y-type
- :low (interval-low bnd)
- :high (interval-high bnd)))
- (t
- ;; A positive rational to a number is a number (for now).
- (specifier-type 'number))))
- ((csubtypep x-type (specifier-type 'float))
- ;; a float to some power
- (case (numeric-type-class y-type)
- ((or integer rational)
- ;; A positive float to an integer or rational power is
- ;; always a float.
- (make-numeric-type
- :class 'float
- :format (numeric-type-format x-type)
- :low (interval-low bnd)
- :high (interval-high bnd)))
- (float
- ;; A positive float to a float power is a float of the
- ;; higher type.
- (make-numeric-type
- :class 'float
- :format (float-format-max (numeric-type-format x-type)
- (numeric-type-format y-type))
- :low (interval-low bnd)
- :high (interval-high bnd)))
- (t
- ;; A positive float to a number is a number (for now)
- (specifier-type 'number))))
- (t
- ;; A number to some power is a number.
- (specifier-type 'number))))
+ ;; an integer to some power
+ (case (numeric-type-class y-type)
+ (integer
+ ;; Positive integer to an integer power is either an
+ ;; integer or a rational.
+ (let ((lo (or (interval-low bnd) '*))
+ (hi (or (interval-high bnd) '*)))
+ (if (and (interval-low y-int)
+ (>= (type-bound-number (interval-low y-int)) 0))
+ (specifier-type `(integer ,lo ,hi))
+ (specifier-type `(rational ,lo ,hi)))))
+ (rational
+ ;; Positive integer to rational power is either a rational
+ ;; or a single-float.
+ (let* ((lo (interval-low bnd))
+ (hi (interval-high bnd))
+ (int-lo (if lo
+ (floor (type-bound-number lo))
+ '*))
+ (int-hi (if hi
+ (ceiling (type-bound-number hi))
+ '*))
+ (f-lo (if lo
+ (bound-func #'float lo)
+ '*))
+ (f-hi (if hi
+ (bound-func #'float hi)
+ '*)))
+ (specifier-type `(or (rational ,int-lo ,int-hi)
+ (single-float ,f-lo, f-hi)))))
+ (float
+ ;; A positive integer to a float power is a float.
+ (modified-numeric-type y-type
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
+ (t
+ ;; A positive integer to a number is a number (for now).
+ (specifier-type 'number))))
+ ((csubtypep x-type (specifier-type 'rational))
+ ;; a rational to some power
+ (case (numeric-type-class y-type)
+ (integer
+ ;; A positive rational to an integer power is always a rational.
+ (specifier-type `(rational ,(or (interval-low bnd) '*)
+ ,(or (interval-high bnd) '*))))
+ (rational
+ ;; A positive rational to rational power is either a rational
+ ;; or a single-float.
+ (let* ((lo (interval-low bnd))
+ (hi (interval-high bnd))
+ (int-lo (if lo
+ (floor (type-bound-number lo))
+ '*))
+ (int-hi (if hi
+ (ceiling (type-bound-number hi))
+ '*))
+ (f-lo (if lo
+ (bound-func #'float lo)
+ '*))
+ (f-hi (if hi
+ (bound-func #'float hi)
+ '*)))
+ (specifier-type `(or (rational ,int-lo ,int-hi)
+ (single-float ,f-lo, f-hi)))))
+ (float
+ ;; A positive rational to a float power is a float.
+ (modified-numeric-type y-type
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
+ (t
+ ;; A positive rational to a number is a number (for now).
+ (specifier-type 'number))))
+ ((csubtypep x-type (specifier-type 'float))
+ ;; a float to some power
+ (case (numeric-type-class y-type)
+ ((or integer rational)
+ ;; A positive float to an integer or rational power is
+ ;; always a float.
+ (make-numeric-type
+ :class 'float
+ :format (numeric-type-format x-type)
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
+ (float
+ ;; A positive float to a float power is a float of the
+ ;; higher type.
+ (make-numeric-type
+ :class 'float
+ :format (float-format-max (numeric-type-format x-type)
+ (numeric-type-format y-type))
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
+ (t
+ ;; A positive float to a number is a number (for now)
+ (specifier-type 'number))))
+ (t
+ ;; A number to some power is a number.
+ (specifier-type 'number))))
(defun merged-interval-expt (x y)
(let* ((x-int (numeric-type->interval x))
- (y-int (numeric-type->interval y)))
+ (y-int (numeric-type->interval y)))
(mapcar (lambda (type)
- (fixup-interval-expt type x-int y-int x y))
- (flatten-list (interval-expt x-int y-int)))))
+ (fixup-interval-expt type x-int y-int x y))
+ (flatten-list (interval-expt x-int y-int)))))
(defun expt-derive-type-aux (x y same-arg)
(declare (ignore same-arg))
(cond ((or (not (numeric-type-real-p x))
- (not (numeric-type-real-p y)))
- ;; Use numeric contagion if either is not real.
- (numeric-contagion x y))
- ((csubtypep y (specifier-type 'integer))
- ;; A real raised to an integer power is well-defined.
- (merged-interval-expt x y))
- ;; A real raised to a non-integral power can be a float or a
- ;; complex number.
- ((or (csubtypep x (specifier-type '(rational 0)))
- (csubtypep x (specifier-type '(float (0d0)))))
- ;; But a positive real to any power is well-defined.
- (merged-interval-expt x y))
- ((and (csubtypep x (specifier-type 'rational))
- (csubtypep x (specifier-type 'rational)))
- ;; A rational to the power of a rational could be a rational
- ;; or a possibly-complex single float
- (specifier-type '(or rational single-float (complex single-float))))
- (t
- ;; a real to some power. The result could be a real or a
- ;; complex.
- (float-or-complex-float-type (numeric-contagion x y)))))
+ (not (numeric-type-real-p y)))
+ ;; Use numeric contagion if either is not real.
+ (numeric-contagion x y))
+ ((csubtypep y (specifier-type 'integer))
+ ;; A real raised to an integer power is well-defined.
+ (merged-interval-expt x y))
+ ;; A real raised to a non-integral power can be a float or a
+ ;; complex number.
+ ((or (csubtypep x (specifier-type '(rational 0)))
+ (csubtypep x (specifier-type '(float (0d0)))))
+ ;; But a positive real to any power is well-defined.
+ (merged-interval-expt x y))
+ ((and (csubtypep x (specifier-type 'rational))
+ (csubtypep x (specifier-type 'rational)))
+ ;; A rational to the power of a rational could be a rational
+ ;; or a possibly-complex single float
+ (specifier-type '(or rational single-float (complex single-float))))
+ (t
+ ;; a real to some power. The result could be a real or a
+ ;; complex.
+ (float-or-complex-float-type (numeric-contagion x y)))))
(defoptimizer (expt derive-type) ((x y))
(two-arg-derive-type x y #'expt-derive-type-aux #'expt))
(defun log-derive-type-aux-2 (x y same-arg)
(let ((log-x (log-derive-type-aux-1 x))
- (log-y (log-derive-type-aux-1 y))
- (accumulated-list nil))
+ (log-y (log-derive-type-aux-1 y))
+ (accumulated-list nil))
;; LOG-X or LOG-Y might be union types. We need to run through
;; the union types ourselves because /-DERIVE-TYPE-AUX doesn't.
(dolist (x-type (prepare-arg-for-derive-type log-x))
(dolist (y-type (prepare-arg-for-derive-type log-y))
- (push (/-derive-type-aux x-type y-type same-arg) accumulated-list)))
+ (push (/-derive-type-aux x-type y-type same-arg) accumulated-list)))
(apply #'type-union (flatten-list accumulated-list))))
(defoptimizer (log derive-type) ((x &optional y))
;; The hard case with two args. We just return the max bounds.
(let ((result-type (numeric-contagion y x)))
(cond ((and (numeric-type-real-p x)
- (numeric-type-real-p y))
- (let* (;; FIXME: This expression for FORMAT seems to
- ;; appear multiple times, and should be factored out.
- (format (case (numeric-type-class result-type)
- ((integer rational) 'single-float)
- (t (numeric-type-format result-type))))
- (bound-format (or format 'float)))
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce (- pi) bound-format)
- :high (coerce pi bound-format))))
- (t
- ;; The result is a float or a complex number
- (float-or-complex-float-type result-type)))))
+ (numeric-type-real-p y))
+ (let* (;; FIXME: This expression for FORMAT seems to
+ ;; appear multiple times, and should be factored out.
+ (format (case (numeric-type-class result-type)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format result-type))))
+ (bound-format (or format 'float)))
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce (- pi) bound-format)
+ :high (coerce pi bound-format))))
+ (t
+ ;; The result is a float or a complex number
+ (float-or-complex-float-type result-type)))))
(defoptimizer (atan derive-type) ((y &optional x))
(if x
(defun phase-derive-type-aux (arg)
(let* ((format (case (numeric-type-class arg)
- ((integer rational) 'single-float)
- (t (numeric-type-format arg))))
- (bound-type (or format 'float)))
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (bound-type (or format 'float)))
(cond ((numeric-type-real-p arg)
- (case (interval-range-info (numeric-type->interval arg) 0.0)
- (+
- ;; The number is positive, so the phase is 0.
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce 0 bound-type)
- :high (coerce 0 bound-type)))
- (-
- ;; The number is always negative, so the phase is pi.
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce pi bound-type)
- :high (coerce pi bound-type)))
- (t
- ;; We can't tell. The result is 0 or pi. Use a union
- ;; type for this.
- (list
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce 0 bound-type)
- :high (coerce 0 bound-type))
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce pi bound-type)
- :high (coerce pi bound-type))))))
- (t
- ;; We have a complex number. The answer is the range -pi
- ;; to pi. (-pi is included because we have -0.)
- (make-numeric-type :class 'float
- :format format
- :complexp :real
- :low (coerce (- pi) bound-type)
- :high (coerce pi bound-type))))))
+ (case (interval-range-info (numeric-type->interval arg) 0.0)
+ (+
+ ;; The number is positive, so the phase is 0.
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce 0 bound-type)
+ :high (coerce 0 bound-type)))
+ (-
+ ;; The number is always negative, so the phase is pi.
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce pi bound-type)
+ :high (coerce pi bound-type)))
+ (t
+ ;; We can't tell. The result is 0 or pi. Use a union
+ ;; type for this.
+ (list
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce 0 bound-type)
+ :high (coerce 0 bound-type))
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce pi bound-type)
+ :high (coerce pi bound-type))))))
+ (t
+ ;; We have a complex number. The answer is the range -pi
+ ;; to pi. (-pi is included because we have -0.)
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce (- pi) bound-type)
+ :high (coerce pi bound-type))))))
(defoptimizer (phase derive-type) ((num))
(one-arg-derive-type num #'phase-derive-type-aux #'phase))
;;; should help a lot in optimized code.
(defun realpart-derive-type-aux (type)
(let ((class (numeric-type-class type))
- (format (numeric-type-format type)))
+ (format (numeric-type-format type)))
(cond ((numeric-type-real-p type)
- ;; The realpart of a real has the same type and range as
- ;; the input.
- (make-numeric-type :class class
- :format format
- :complexp :real
- :low (numeric-type-low type)
- :high (numeric-type-high type)))
- (t
- ;; We have a complex number. The result has the same type
- ;; as the real part, except that it's real, not complex,
- ;; obviously.
- (make-numeric-type :class class
- :format format
- :complexp :real
- :low (numeric-type-low type)
- :high (numeric-type-high type))))))
+ ;; The realpart of a real has the same type and range as
+ ;; the input.
+ (make-numeric-type :class class
+ :format format
+ :complexp :real
+ :low (numeric-type-low type)
+ :high (numeric-type-high type)))
+ (t
+ ;; We have a complex number. The result has the same type
+ ;; as the real part, except that it's real, not complex,
+ ;; obviously.
+ (make-numeric-type :class class
+ :format format
+ :complexp :real
+ :low (numeric-type-low type)
+ :high (numeric-type-high type))))))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (realpart derive-type) ((num))
(one-arg-derive-type num #'realpart-derive-type-aux #'realpart))
(defun imagpart-derive-type-aux (type)
(let ((class (numeric-type-class type))
- (format (numeric-type-format type)))
+ (format (numeric-type-format type)))
(cond ((numeric-type-real-p type)
- ;; The imagpart of a real has the same type as the input,
- ;; except that it's zero.
- (let ((bound-format (or format class 'real)))
- (make-numeric-type :class class
- :format format
- :complexp :real
- :low (coerce 0 bound-format)
- :high (coerce 0 bound-format))))
- (t
- ;; We have a complex number. The result has the same type as
- ;; the imaginary part, except that it's real, not complex,
- ;; obviously.
- (make-numeric-type :class class
- :format format
- :complexp :real
- :low (numeric-type-low type)
- :high (numeric-type-high type))))))
+ ;; The imagpart of a real has the same type as the input,
+ ;; except that it's zero.
+ (let ((bound-format (or format class 'real)))
+ (make-numeric-type :class class
+ :format format
+ :complexp :real
+ :low (coerce 0 bound-format)
+ :high (coerce 0 bound-format))))
+ (t
+ ;; We have a complex number. The result has the same type as
+ ;; the imaginary part, except that it's real, not complex,
+ ;; obviously.
+ (make-numeric-type :class class
+ :format format
+ :complexp :real
+ :low (numeric-type-low type)
+ :high (numeric-type-high type))))))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (imagpart derive-type) ((num))
(one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart))
(defun complex-derive-type-aux-1 (re-type)
(if (numeric-type-p re-type)
(make-numeric-type :class (numeric-type-class re-type)
- :format (numeric-type-format re-type)
- :complexp (if (csubtypep re-type
- (specifier-type 'rational))
- :real
- :complex)
- :low (numeric-type-low re-type)
- :high (numeric-type-high re-type))
+ :format (numeric-type-format re-type)
+ :complexp (if (csubtypep re-type
+ (specifier-type 'rational))
+ :real
+ :complex)
+ :low (numeric-type-low re-type)
+ :high (numeric-type-high re-type))
(specifier-type 'complex)))
(defun complex-derive-type-aux-2 (re-type im-type same-arg)
(declare (ignore same-arg))
(if (and (numeric-type-p re-type)
- (numeric-type-p im-type))
+ (numeric-type-p im-type))
;; Need to check to make sure numeric-contagion returns the
;; right type for what we want here.
;; arguments are rational, we make it a union type of (or
;; rational (complex rational)).
(let* ((element-type (numeric-contagion re-type im-type))
- (rat-result-p (csubtypep element-type
- (specifier-type 'rational))))
- (if rat-result-p
- (type-union element-type
- (specifier-type
- `(complex ,(numeric-type-class element-type))))
- (make-numeric-type :class (numeric-type-class element-type)
- :format (numeric-type-format element-type)
- :complexp (if rat-result-p
- :real
- :complex))))
+ (rat-result-p (csubtypep element-type
+ (specifier-type 'rational))))
+ (if rat-result-p
+ (type-union element-type
+ (specifier-type
+ `(complex ,(numeric-type-class element-type))))
+ (make-numeric-type :class (numeric-type-class element-type)
+ :format (numeric-type-format element-type)
+ :complexp (if rat-result-p
+ :real
+ :complex))))
(specifier-type 'complex)))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
;;; Define some transforms for complex operations. We do this in lieu
;;; of complex operation VOPs.
(macrolet ((frob (type)
- `(progn
- ;; negation
- (deftransform %negate ((z) ((complex ,type)) *)
- '(complex (%negate (realpart z)) (%negate (imagpart z))))
- ;; complex addition and subtraction
- (deftransform + ((w z) ((complex ,type) (complex ,type)) *)
- '(complex (+ (realpart w) (realpart z))
- (+ (imagpart w) (imagpart z))))
- (deftransform - ((w z) ((complex ,type) (complex ,type)) *)
- '(complex (- (realpart w) (realpart z))
- (- (imagpart w) (imagpart z))))
- ;; Add and subtract a complex and a real.
- (deftransform + ((w z) ((complex ,type) real) *)
- '(complex (+ (realpart w) z) (imagpart w)))
- (deftransform + ((z w) (real (complex ,type)) *)
- '(complex (+ (realpart w) z) (imagpart w)))
- ;; Add and subtract a real and a complex number.
- (deftransform - ((w z) ((complex ,type) real) *)
- '(complex (- (realpart w) z) (imagpart w)))
- (deftransform - ((z w) (real (complex ,type)) *)
- '(complex (- z (realpart w)) (- (imagpart w))))
- ;; Multiply and divide two complex numbers.
- (deftransform * ((x y) ((complex ,type) (complex ,type)) *)
- '(let* ((rx (realpart x))
- (ix (imagpart x))
- (ry (realpart y))
- (iy (imagpart y)))
- (complex (- (* rx ry) (* ix iy))
- (+ (* rx iy) (* ix ry)))))
- (deftransform / ((x y) ((complex ,type) (complex ,type)) *)
- '(let* ((rx (realpart x))
- (ix (imagpart x))
- (ry (realpart y))
- (iy (imagpart y)))
- (if (> (abs ry) (abs iy))
- (let* ((r (/ iy ry))
- (dn (* ry (+ 1 (* r r)))))
- (complex (/ (+ rx (* ix r)) dn)
- (/ (- ix (* rx r)) dn)))
- (let* ((r (/ ry iy))
- (dn (* iy (+ 1 (* r r)))))
- (complex (/ (+ (* rx r) ix) dn)
- (/ (- (* ix r) rx) dn))))))
- ;; Multiply a complex by a real or vice versa.
- (deftransform * ((w z) ((complex ,type) real) *)
- '(complex (* (realpart w) z) (* (imagpart w) z)))
- (deftransform * ((z w) (real (complex ,type)) *)
- '(complex (* (realpart w) z) (* (imagpart w) z)))
- ;; Divide a complex by a real.
- (deftransform / ((w z) ((complex ,type) real) *)
- '(complex (/ (realpart w) z) (/ (imagpart w) z)))
- ;; conjugate of complex number
- (deftransform conjugate ((z) ((complex ,type)) *)
- '(complex (realpart z) (- (imagpart z))))
- ;; CIS
- (deftransform cis ((z) ((,type)) *)
- '(complex (cos z) (sin z)))
- ;; comparison
- (deftransform = ((w z) ((complex ,type) (complex ,type)) *)
- '(and (= (realpart w) (realpart z))
- (= (imagpart w) (imagpart z))))
- (deftransform = ((w z) ((complex ,type) real) *)
- '(and (= (realpart w) z) (zerop (imagpart w))))
- (deftransform = ((w z) (real (complex ,type)) *)
- '(and (= (realpart z) w) (zerop (imagpart z)))))))
+ `(progn
+ ;; negation
+ (deftransform %negate ((z) ((complex ,type)) *)
+ '(complex (%negate (realpart z)) (%negate (imagpart z))))
+ ;; complex addition and subtraction
+ (deftransform + ((w z) ((complex ,type) (complex ,type)) *)
+ '(complex (+ (realpart w) (realpart z))
+ (+ (imagpart w) (imagpart z))))
+ (deftransform - ((w z) ((complex ,type) (complex ,type)) *)
+ '(complex (- (realpart w) (realpart z))
+ (- (imagpart w) (imagpart z))))
+ ;; Add and subtract a complex and a real.
+ (deftransform + ((w z) ((complex ,type) real) *)
+ '(complex (+ (realpart w) z) (imagpart w)))
+ (deftransform + ((z w) (real (complex ,type)) *)
+ '(complex (+ (realpart w) z) (imagpart w)))
+ ;; Add and subtract a real and a complex number.
+ (deftransform - ((w z) ((complex ,type) real) *)
+ '(complex (- (realpart w) z) (imagpart w)))
+ (deftransform - ((z w) (real (complex ,type)) *)
+ '(complex (- z (realpart w)) (- (imagpart w))))
+ ;; Multiply and divide two complex numbers.
+ (deftransform * ((x y) ((complex ,type) (complex ,type)) *)
+ '(let* ((rx (realpart x))
+ (ix (imagpart x))
+ (ry (realpart y))
+ (iy (imagpart y)))
+ (complex (- (* rx ry) (* ix iy))
+ (+ (* rx iy) (* ix ry)))))
+ (deftransform / ((x y) ((complex ,type) (complex ,type)) *)
+ '(let* ((rx (realpart x))
+ (ix (imagpart x))
+ (ry (realpart y))
+ (iy (imagpart y)))
+ (if (> (abs ry) (abs iy))
+ (let* ((r (/ iy ry))
+ (dn (* ry (+ 1 (* r r)))))
+ (complex (/ (+ rx (* ix r)) dn)
+ (/ (- ix (* rx r)) dn)))
+ (let* ((r (/ ry iy))
+ (dn (* iy (+ 1 (* r r)))))
+ (complex (/ (+ (* rx r) ix) dn)
+ (/ (- (* ix r) rx) dn))))))
+ ;; Multiply a complex by a real or vice versa.
+ (deftransform * ((w z) ((complex ,type) real) *)
+ '(complex (* (realpart w) z) (* (imagpart w) z)))
+ (deftransform * ((z w) (real (complex ,type)) *)
+ '(complex (* (realpart w) z) (* (imagpart w) z)))
+ ;; Divide a complex by a real.
+ (deftransform / ((w z) ((complex ,type) real) *)
+ '(complex (/ (realpart w) z) (/ (imagpart w) z)))
+ ;; conjugate of complex number
+ (deftransform conjugate ((z) ((complex ,type)) *)
+ '(complex (realpart z) (- (imagpart z))))
+ ;; CIS
+ (deftransform cis ((z) ((,type)) *)
+ '(complex (cos z) (sin z)))
+ ;; comparison
+ (deftransform = ((w z) ((complex ,type) (complex ,type)) *)
+ '(and (= (realpart w) (realpart z))
+ (= (imagpart w) (imagpart z))))
+ (deftransform = ((w z) ((complex ,type) real) *)
+ '(and (= (realpart w) z) (zerop (imagpart w))))
+ (deftransform = ((w z) (real (complex ,type)) *)
+ '(and (= (realpart z) w) (zerop (imagpart z)))))))
(frob single-float)
(frob double-float))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun trig-derive-type-aux (arg domain fcn
- &optional def-lo def-hi (increasingp t))
+ &optional def-lo def-hi (increasingp t))
(etypecase arg
(numeric-type
(cond ((eq (numeric-type-complexp arg) :complex)
- (make-numeric-type :class (numeric-type-class arg)
- :format (numeric-type-format arg)
- :complexp :complex))
- ((numeric-type-real-p arg)
- (let* ((format (case (numeric-type-class arg)
- ((integer rational) 'single-float)
- (t (numeric-type-format arg))))
- (bound-type (or format 'float)))
- ;; If the argument is a subset of the "principal" domain
- ;; of the function, we can compute the bounds because
- ;; the function is monotonic. We can't do this in
- ;; general for these periodic functions because we can't
- ;; (and don't want to) do the argument reduction in
- ;; exactly the same way as the functions themselves do
- ;; it.
- (if (csubtypep arg domain)
- (let ((res-lo (bound-func fcn (numeric-type-low arg)))
- (res-hi (bound-func fcn (numeric-type-high arg))))
- (unless increasingp
- (rotatef res-lo res-hi))
- (make-numeric-type
- :class 'float
- :format format
- :low (coerce-numeric-bound res-lo bound-type)
- :high (coerce-numeric-bound res-hi bound-type)))
- (make-numeric-type
- :class 'float
- :format format
- :low (and def-lo (coerce def-lo bound-type))
- :high (and def-hi (coerce def-hi bound-type))))))
- (t
- (float-or-complex-float-type arg def-lo def-hi))))))
+ (make-numeric-type :class (numeric-type-class arg)
+ :format (numeric-type-format arg)
+ :complexp :complex))
+ ((numeric-type-real-p arg)
+ (let* ((format (case (numeric-type-class arg)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (bound-type (or format 'float)))
+ ;; If the argument is a subset of the "principal" domain
+ ;; of the function, we can compute the bounds because
+ ;; the function is monotonic. We can't do this in
+ ;; general for these periodic functions because we can't
+ ;; (and don't want to) do the argument reduction in
+ ;; exactly the same way as the functions themselves do
+ ;; it.
+ (if (csubtypep arg domain)
+ (let ((res-lo (bound-func fcn (numeric-type-low arg)))
+ (res-hi (bound-func fcn (numeric-type-high arg))))
+ (unless increasingp
+ (rotatef res-lo res-hi))
+ (make-numeric-type
+ :class 'float
+ :format format
+ :low (coerce-numeric-bound res-lo bound-type)
+ :high (coerce-numeric-bound res-hi bound-type)))
+ (make-numeric-type
+ :class 'float
+ :format format
+ :low (and def-lo (coerce def-lo bound-type))
+ :high (and def-hi (coerce def-hi bound-type))))))
+ (t
+ (float-or-complex-float-type arg def-lo def-hi))))))
(defoptimizer (sin derive-type) ((num))
(one-arg-derive-type
(lambda (arg)
;; Derive the bounds if the arg is in [0, pi].
(trig-derive-type-aux arg
- (specifier-type `(float 0d0 ,pi))
- #'cos
- -1 1
- nil))
+ (specifier-type `(float 0d0 ,pi))
+ #'cos
+ -1 1
+ nil))
#'cos))
(defoptimizer (tan derive-type) ((num))
(lambda (arg)
;; Derive the bounds if the arg is in [-pi/2, pi/2].
(trig-derive-type-aux arg
- (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
- #'tan
- nil nil))
+ (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
+ #'tan
+ nil nil))
#'tan))
(defoptimizer (conjugate derive-type) ((num))
(one-arg-derive-type num
(lambda (arg)
(flet ((most-negative-bound (l h)
- (and l h
- (if (< (type-bound-number l) (- (type-bound-number h)))
- l
- (set-bound (- (type-bound-number h)) (consp h)))))
- (most-positive-bound (l h)
- (and l h
- (if (> (type-bound-number h) (- (type-bound-number l)))
- h
- (set-bound (- (type-bound-number l)) (consp l))))))
- (if (numeric-type-real-p arg)
- (lvar-type num)
- (let ((low (numeric-type-low arg))
- (high (numeric-type-high arg)))
- (let ((new-low (most-negative-bound low high))
- (new-high (most-positive-bound low high)))
- (modified-numeric-type arg :low new-low :high new-high))))))
+ (and l h
+ (if (< (type-bound-number l) (- (type-bound-number h)))
+ l
+ (set-bound (- (type-bound-number h)) (consp h)))))
+ (most-positive-bound (l h)
+ (and l h
+ (if (> (type-bound-number h) (- (type-bound-number l)))
+ h
+ (set-bound (- (type-bound-number l)) (consp l))))))
+ (if (numeric-type-real-p arg)
+ (lvar-type num)
+ (let ((low (numeric-type-low arg))
+ (high (numeric-type-high arg)))
+ (let ((new-low (most-negative-bound low high))
+ (new-high (most-positive-bound low high)))
+ (modified-numeric-type arg :low new-low :high new-high))))))
#'conjugate))
(defoptimizer (cis derive-type) ((num))
;;;; TRUNCATE, FLOOR, CEILING, and ROUND
(macrolet ((define-frobs (fun ufun)
- `(progn
- (defknown ,ufun (real) integer (movable foldable flushable))
- (deftransform ,fun ((x &optional by)
- (* &optional
- (constant-arg (member 1))))
- '(let ((res (,ufun x)))
- (values res (- x res)))))))
+ `(progn
+ (defknown ,ufun (real) integer (movable foldable flushable))
+ (deftransform ,fun ((x &optional by)
+ (* &optional
+ (constant-arg (member 1))))
+ '(let ((res (,ufun x)))
+ (values res (- x res)))))))
(define-frobs truncate %unary-truncate)
(define-frobs round %unary-round))
(let ((defaulted-divisor (if divisor 'divisor 1)))
`(multiple-value-bind (tru rem) (truncate number ,defaulted-divisor)
(if (and (not (zerop rem))
- (if (minusp ,defaulted-divisor)
- (plusp number)
- (minusp number)))
- (values (1- tru) (+ rem ,defaulted-divisor))
- (values tru rem)))))
+ (if (minusp ,defaulted-divisor)
+ (plusp number)
+ (minusp number)))
+ (values (1- tru) (+ rem ,defaulted-divisor))
+ (values tru rem)))))
(deftransform ceiling ((number &optional divisor)
(float &optional (or integer float)))
(let ((defaulted-divisor (if divisor 'divisor 1)))
`(multiple-value-bind (tru rem) (truncate number ,defaulted-divisor)
(if (and (not (zerop rem))
- (if (minusp ,defaulted-divisor)
- (minusp number)
- (plusp number)))
- (values (1+ tru) (- rem ,defaulted-divisor))
- (values tru rem)))))
+ (if (minusp ,defaulted-divisor)
+ (minusp number)
+ (plusp number)))
+ (values (1+ tru) (- rem ,defaulted-divisor))
+ (values tru rem)))))
(defknown %unary-ftruncate (real) float (movable foldable flushable))
(defknown %unary-ftruncate/single (single-float) single-float
(declare (type single-float x))
(declare (optimize speed (safety 0)))
(let* ((bits (single-float-bits x))
- (exp (ldb sb!vm:single-float-exponent-byte bits))
- (biased (the single-float-exponent
- (- exp sb!vm:single-float-bias))))
+ (exp (ldb sb!vm:single-float-exponent-byte bits))
+ (biased (the single-float-exponent
+ (- exp sb!vm:single-float-bias))))
(declare (type (signed-byte 32) bits))
(cond
((= exp sb!vm:single-float-normal-exponent-max) x)
((>= biased (float-digits x)) x)
(t
(let ((frac-bits (- (float-digits x) biased)))
- (setf bits (logandc2 bits (- (ash 1 frac-bits) 1)))
- (make-single-float bits))))))
+ (setf bits (logandc2 bits (- (ash 1 frac-bits) 1)))
+ (make-single-float bits))))))
(defun %unary-ftruncate/double (x)
(declare (type double-float x))
(declare (optimize speed (safety 0)))
(let* ((high (double-float-high-bits x))
- (low (double-float-low-bits x))
- (exp (ldb sb!vm:double-float-exponent-byte high))
- (biased (the double-float-exponent
- (- exp sb!vm:double-float-bias))))
+ (low (double-float-low-bits x))
+ (exp (ldb sb!vm:double-float-exponent-byte high))
+ (biased (the double-float-exponent
+ (- exp sb!vm:double-float-bias))))
(declare (type (signed-byte 32) high)
- (type (unsigned-byte 32) low))
+ (type (unsigned-byte 32) low))
(cond
((= exp sb!vm:double-float-normal-exponent-max) x)
((<= biased 0) (* x 0d0))
((>= biased (float-digits x)) x)
(t
(let ((frac-bits (- (float-digits x) biased)))
- (cond ((< frac-bits 32)
- (setf low (logandc2 low (- (ash 1 frac-bits) 1))))
- (t
- (setf low 0)
- (setf high (logandc2 high (- (ash 1 (- frac-bits 32)) 1)))))
- (make-double-float high low))))))
+ (cond ((< frac-bits 32)
+ (setf low (logandc2 low (- (ash 1 frac-bits) 1))))
+ (t
+ (setf low 0)
+ (setf high (logandc2 high (- (ash 1 (- frac-bits 32)) 1)))))
+ (make-double-float high low))))))
(macrolet
((def (float-type fun)
- `(deftransform %unary-ftruncate ((x) (,float-type))
- '(,fun x))))
+ `(deftransform %unary-ftruncate ((x) (,float-type))
+ '(,fun x))))
(def single-float %unary-ftruncate/single)
(def double-float %unary-ftruncate/double))
;;; These can be affected by type definitions, so they're not FOLDABLE.
(defknown (sb!xc:upgraded-complex-part-type sb!xc:upgraded-array-element-type)
- (type-specifier &optional lexenv-designator) type-specifier
+ (type-specifier &optional lexenv-designator) type-specifier
(unsafely-flushable))
\f
;;;; from the "Predicates" chapter:
(unsafely-flushable))
(defknown (null symbolp atom consp listp numberp integerp rationalp floatp
- complexp characterp stringp bit-vector-p vectorp
- simple-vector-p simple-string-p simple-bit-vector-p arrayp
- sb!xc:packagep functionp compiled-function-p not)
+ complexp characterp stringp bit-vector-p vectorp
+ simple-vector-p simple-string-p simple-bit-vector-p arrayp
+ sb!xc:packagep functionp compiled-function-p not)
(t) boolean (movable foldable flushable))
(defknown (eq eql) (t t) boolean (movable foldable flushable))
(defknown copy-symbol (symbol &optional t) symbol (flushable))
(defknown gensym (&optional (or string unsigned-byte)) symbol ())
(defknown symbol-package (symbol) (or sb!xc:package null) (flushable))
-(defknown keywordp (t) boolean (flushable)) ; If someone uninterns it...
+(defknown keywordp (t) boolean (flushable)) ; If someone uninterns it...
\f
;;;; from the "Packages" chapter:
(defknown gentemp (&optional string package-designator) symbol)
(defknown make-package (string-designator &key
- (:use list)
- (:nicknames list)
- ;; ### extensions...
- (:internal-symbols index)
- (:external-symbols index))
+ (:use list)
+ (:nicknames list)
+ ;; ### extensions...
+ (:internal-symbols index)
+ (:external-symbols index))
sb!xc:package)
(defknown find-package (package-designator) (or sb!xc:package null)
(flushable))
(defknown find-symbol (string &optional package-designator)
(values symbol (member :internal :external :inherited nil))
(flushable))
-(defknown (export import) (symbols-designator &optional package-designator)
+(defknown (export import) (symbols-designator &optional package-designator)
(eql t))
(defknown unintern (symbol &optional package-designator) boolean)
(defknown unexport (symbols-designator &optional package-designator) (eql t))
(defknown (float-digits float-precision) (float) float-digits
(movable foldable flushable explicit-check))
(defknown integer-decode-float (float)
- (values integer float-int-exponent (member -1 1))
- (movable foldable flushable explicit-check))
+ (values integer float-int-exponent (member -1 1))
+ (movable foldable flushable explicit-check))
(defknown complex (real &optional real) number
(movable foldable flushable explicit-check))
(movable foldable flushable explicit-check))
(defknown (lognand lognor logandc1 logandc2 logorc1 logorc2)
- (integer integer) integer
+ (integer integer) integer
(movable foldable flushable explicit-check))
(defknown boole (boole-code integer integer) integer
\f
;;;; from the "Characters" chapter:
(defknown (standard-char-p graphic-char-p alpha-char-p
- upper-case-p lower-case-p both-case-p alphanumericp)
+ upper-case-p lower-case-p both-case-p alphanumericp)
(character) boolean (movable foldable flushable))
(defknown digit-char-p (character &optional (integer 2 36))
(or (integer 0 35) null) (movable foldable flushable))
(defknown (char= char/= char< char> char<= char>= char-equal char-not-equal
- char-lessp char-greaterp char-not-greaterp char-not-lessp)
+ char-lessp char-greaterp char-not-greaterp char-not-lessp)
(character &rest character) boolean (movable foldable flushable))
(defknown character (t) character (movable foldable unsafely-flushable))
:derive-type #'result-type-first-arg)
(defknown make-sequence (type-specifier index
- &key
- (:initial-element t))
+ &key
+ (:initial-element t))
consed-sequence
(movable unsafe)
:derive-type (creation-result-type-specifier-nth-arg 1))
;;; unsafe for :INITIAL-VALUE...
(defknown reduce (callable
- sequence
- &key
- (:from-end t)
- (:start index)
- (:end sequence-end)
- (:initial-value t)
- (:key callable))
+ sequence
+ &key
+ (:from-end t)
+ (:start index)
+ (:end sequence-end)
+ (:initial-value t)
+ (:key callable))
t
(foldable flushable call unsafe))
:derive-type #'result-type-first-arg)
(defknown replace (sequence
- sequence
- &key
- (:start1 index)
- (:end1 sequence-end)
- (:start2 index)
- (:end2 sequence-end))
+ sequence
+ &key
+ (:start1 index)
+ (:end1 sequence-end)
+ (:start2 index)
+ (:end2 sequence-end))
sequence ()
:derive-type #'result-type-first-arg)
(defknown (remove-if remove-if-not)
(callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:count sequence-count) (:key callable))
+ (:count sequence-count) (:key callable))
consed-sequence
(flushable call)
:derive-type (sequence-result-nth-arg 2))
(defknown (delete-if delete-if-not)
(callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:count sequence-count) (:key callable))
+ (:count sequence-count) (:key callable))
sequence
(flushable call)
:derive-type (sequence-result-nth-arg 2))
(defknown remove-duplicates
(sequence &key (:test callable) (:test-not callable) (:start index)
- (:from-end t) (:end sequence-end) (:key callable))
+ (:from-end t) (:end sequence-end) (:key callable))
consed-sequence
(unsafely-flushable call)
:derive-type (sequence-result-nth-arg 1))
(defknown delete-duplicates
(sequence &key (:test callable) (:test-not callable) (:start index)
- (:from-end t) (:end sequence-end) (:key callable))
+ (:from-end t) (:end sequence-end) (:key callable))
sequence
(unsafely-flushable call)
:derive-type (sequence-result-nth-arg 1))
(defknown find (t sequence &key (:test callable) (:test-not callable)
- (:start index) (:from-end t) (:end sequence-end)
- (:key callable))
+ (:start index) (:from-end t) (:end sequence-end)
+ (:key callable))
t
(foldable flushable call))
(defknown (find-if find-if-not)
(callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:key callable))
+ (:key callable))
t
(foldable flushable call))
(defknown position (t sequence &key (:test callable) (:test-not callable)
- (:start index) (:from-end t) (:end sequence-end)
- (:key callable))
+ (:start index) (:from-end t) (:end sequence-end)
+ (:key callable))
(or index null)
(foldable flushable call))
(defknown (position-if position-if-not)
(callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:key callable))
+ (:key callable))
(or index null)
(foldable flushable call))
(defknown count (t sequence &key (:test callable) (:test-not callable)
- (:start index) (:from-end t) (:end sequence-end)
- (:key callable))
+ (:start index) (:from-end t) (:end sequence-end)
+ (:key callable))
index
(foldable flushable call))
(defknown (count-if count-if-not)
(callable sequence &key (:from-end t) (:start index) (:end sequence-end)
- (:key callable))
+ (:key callable))
index
(foldable flushable call))
(defknown (mismatch search)
(sequence sequence &key (:from-end t) (:test callable) (:test-not callable)
- (:start1 index) (:end1 sequence-end)
- (:start2 index) (:end2 sequence-end)
- (:key callable))
+ (:start1 index) (:end1 sequence-end)
+ (:start2 index) (:end2 sequence-end)
+ (:key callable))
(or index null)
(foldable flushable call))
(call))
(defknown merge (type-specifier sequence sequence callable
- &key (:key callable))
+ &key (:key callable))
sequence
(call)
:derive-type (creation-result-type-specifier-nth-arg 1))
;;; not FLUSHABLE, despite what CMU CL's DEFKNOWN said..
(defknown read-sequence (sequence stream
- &key
- (:start index)
- (:end sequence-end))
+ &key
+ (:start index)
+ (:end sequence-end))
(index)
())
(defknown write-sequence (sequence stream
- &key
- (:start index)
- (:end sequence-end))
+ &key
+ (:start index)
+ (:end sequence-end))
sequence
()
:derive-type (sequence-result-nth-arg 1))
(defknown (rplaca rplacd) (cons t) list (unsafe))
(defknown (nsubst subst) (t t t &key (:key callable) (:test callable)
- (:test-not callable))
+ (:test-not callable))
t (flushable unsafe call))
(defknown (subst-if subst-if-not nsubst-if nsubst-if-not)
- (t callable t &key (:key callable))
+ (t callable t &key (:key callable))
t (flushable unsafe call))
(defknown (sublis nsublis) (list t &key (:key callable) (:test callable)
- (:test-not callable))
+ (:test-not callable))
t (flushable unsafe call))
(defknown member (t list &key (:key callable) (:test callable)
- (:test-not callable))
+ (:test-not callable))
list (foldable flushable call))
(defknown (member-if member-if-not) (callable list &key (:key callable))
list (foldable flushable call))
(defknown tailp (t list) boolean (foldable flushable))
(defknown adjoin (t list &key (:key callable) (:test callable)
- (:test-not callable))
+ (:test-not callable))
list (foldable flushable unsafe call))
(defknown (union intersection set-difference set-exclusive-or)
(defknown pairlis (t t &optional t) list (flushable unsafe))
(defknown (rassoc assoc)
- (t list &key (:key callable) (:test callable) (:test-not callable))
+ (t list &key (:key callable) (:test callable) (:test-not callable))
list (foldable flushable call))
(defknown (assoc-if-not assoc-if rassoc-if rassoc-if-not)
- (callable list &key (:key callable)) list (foldable flushable call))
+ (callable list &key (:key callable)) list (foldable flushable call))
(defknown (memq assq) (t list) list (foldable flushable unsafe))
(defknown delq (t list) list (flushable unsafe))
;;;; from the "Arrays" chapter
(defknown make-array ((or index list)
- &key
- (:element-type type-specifier)
- (:initial-element t)
- (:initial-contents t)
- (:adjustable t)
- (:fill-pointer t)
- (:displaced-to (or array null))
- (:displaced-index-offset index))
+ &key
+ (:element-type type-specifier)
+ (:initial-element t)
+ (:initial-contents t)
+ (:adjustable t)
+ (:fill-pointer t)
+ (:displaced-to (or array null))
+ (:displaced-index-offset index))
array (flushable unsafe))
(defknown vector (&rest t) simple-vector (flushable unsafe))
(defknown sbit ((simple-array bit) &rest index) bit (foldable flushable))
(defknown (bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
- bit-orc1 bit-orc2)
+ bit-orc1 bit-orc2)
((array bit) (array bit) &optional (or (array bit) (member t nil)))
(array bit)
()
(defknown adjust-array
(array (or index list) &key (:element-type type-specifier)
- (:initial-element t) (:initial-contents t)
- (:fill-pointer t) (:displaced-to (or array null))
- (:displaced-index-offset index))
+ (:initial-element t) (:initial-contents t)
+ (:fill-pointer t) (:displaced-to (or array null))
+ (:displaced-index-offset index))
array (unsafe))
; :derive-type 'result-type-arg1) Not even close...
\f
(defknown (string= string-equal)
(string-designator string-designator &key (:start1 index) (:end1 sequence-end)
- (:start2 index) (:end2 sequence-end))
+ (:start2 index) (:end2 sequence-end))
boolean
(foldable flushable))
(defknown (string< string> string<= string>= string/= string-lessp
- string-greaterp string-not-lessp string-not-greaterp
- string-not-equal)
+ string-greaterp string-not-lessp string-not-greaterp
+ string-not-equal)
(string-designator string-designator &key (:start1 index) (:end1 sequence-end)
- (:start2 index) (:end2 sequence-end))
+ (:start2 index) (:end2 sequence-end))
(or index null)
(foldable flushable))
(defknown make-string (index &key (:element-type type-specifier)
- (:initial-element character))
+ (:initial-element character))
simple-string (flushable))
(defknown (string-trim string-left-trim string-right-trim)
(defknown make-string-input-stream (string &optional index sequence-end)
stream
(flushable unsafe))
-(defknown make-string-output-stream
- (&key (:element-type type-specifier))
- stream
+(defknown make-string-output-stream
+ (&key (:element-type type-specifier))
+ stream
(flushable))
(defknown get-output-stream-string (stream) simple-string ())
(defknown streamp (t) boolean (movable foldable flushable))
(explicit-check))
(defknown unread-char (character &optional stream-designator) t
(explicit-check))
-(defknown peek-char (&optional (or character (member nil t))
- stream-designator t t t)
+(defknown peek-char (&optional (or character (member nil t))
+ stream-designator t t t)
t
(explicit-check))
(defknown listen (&optional stream-designator) boolean (flushable explicit-check))
(defknown read-from-string
(string &optional t t
- &key
- (:start index)
- (:end sequence-end)
- (:preserve-whitespace t))
+ &key
+ (:start index)
+ (:end sequence-end)
+ (:preserve-whitespace t))
(values t index))
(defknown parse-integer
(string &key
- (:start index)
- (:end sequence-end)
- (:radix (integer 2 36))
- (:junk-allowed t))
+ (:start index)
+ (:end sequence-end)
+ (:radix (integer 2 36))
+ (:junk-allowed t))
(values (or integer null ()) index))
(defknown read-byte (stream &optional t t) t (explicit-check))
(any explicit-check)
:derive-type #'result-type-first-arg)
-(defknown (prin1 print princ) (t &optional stream-designator)
- t
+(defknown (prin1 print princ) (t &optional stream-designator)
+ t
(any explicit-check)
:derive-type #'result-type-first-arg)
(defknown write-byte (integer stream) integer
(explicit-check))
-(defknown format ((or (member nil t) stream string)
- (or string function) &rest t)
+(defknown format ((or (member nil t) stream string)
+ (or string function) &rest t)
(or string null)
(explicit-check))
;;; parsing of a PATHNAME-DESIGNATOR might signal an error.)
(defknown wild-pathname-p (pathname-designator
- &optional
- (member nil :host :device
- :directory :name
- :type :version))
+ &optional
+ (member nil :host :device
+ :directory :name
+ :type :version))
generalized-boolean
())
(defknown pathname-match-p (pathname-designator pathname-designator)
generalized-boolean
())
(defknown translate-pathname (pathname-designator
- pathname-designator
- pathname-designator &key)
+ pathname-designator
+ pathname-designator &key)
pathname
())
(pathname-designator &optional
(or list host string (member :unspecific))
pathname-designator
- &key
- (:start index)
- (:end sequence-end)
- (:junk-allowed t))
+ &key
+ (:start index)
+ (:end sequence-end)
+ (:junk-allowed t))
(values (or pathname null) sequence-end)
())
(defknown pathnamep (t) boolean (movable flushable))
(defknown pathname-host (pathname-designator
- &key (:case (member :local :common)))
+ &key (:case (member :local :common)))
pathname-host (flushable))
(defknown pathname-device (pathname-designator
- &key (:case (member :local :common)))
+ &key (:case (member :local :common)))
pathname-device (flushable))
(defknown pathname-directory (pathname-designator
- &key (:case (member :local :common)))
+ &key (:case (member :local :common)))
pathname-directory (flushable))
(defknown pathname-name (pathname-designator
- &key (:case (member :local :common)))
+ &key (:case (member :local :common)))
pathname-name (flushable))
(defknown pathname-type (pathname-designator
- &key (:case (member :local :common)))
+ &key (:case (member :local :common)))
pathname-type (flushable))
(defknown pathname-version (pathname-designator)
pathname-version (flushable))
(defknown open
(pathname-designator &key
- (:direction (member :input :output :io :probe))
- (:element-type type-specifier)
- (:if-exists (member :error :new-version :rename
- :rename-and-delete :overwrite
- :append :supersede nil))
- (:if-does-not-exist (member :error :create nil))
- (:external-format keyword))
+ (:direction (member :input :output :io :probe))
+ (:element-type type-specifier)
+ (:if-exists (member :error :new-version :rename
+ :rename-and-delete :overwrite
+ :append :supersede nil))
+ (:if-does-not-exist (member :error :create nil))
+ (:external-format keyword))
(or stream null))
(defknown rename-file (pathname-designator filename)
())
(defknown file-position (stream &optional
- (or unsigned-byte (member :start :end)))
+ (or unsigned-byte (member :start :end)))
(or unsigned-byte (member t nil)))
(defknown file-length (stream) (or unsigned-byte null) (unsafely-flushable))
;; ANSI options
(:output-file (or pathname-designator
- null
- ;; FIXME: This last case is a non-ANSI hack.
- (member t)))
+ null
+ ;; FIXME: This last case is a non-ANSI hack.
+ (member t)))
(:verbose t)
(:print t)
(:external-format keyword)
;; FIXME: consider making (OR CALLABLE CONS) something like
;; EXTENDED-FUNCTION-DESIGNATOR
(defknown disassemble ((or callable cons) &key
- (:stream stream) (:use-labels t))
+ (:stream stream) (:use-labels t))
null)
(defknown fdocumentation (t symbol)
(defknown get-decoded-time ()
(values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
- (integer 1 12) unsigned-byte (integer 0 6) boolean (rational -24 24))
+ (integer 1 12) unsigned-byte (integer 0 6) boolean (rational -24 24))
(flushable))
(defknown get-universal-time () unsigned-byte (flushable))
(defknown decode-universal-time
- (unsigned-byte &optional (or null (rational -24 24)))
+ (unsigned-byte &optional (or null (rational -24 24)))
(values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
- (integer 1 12) unsigned-byte (integer 0 6) boolean (rational -24 24))
+ (integer 1 12) unsigned-byte (integer 0 6) boolean (rational -24 24))
(flushable))
(defknown encode-universal-time
;;; available, so -- unlike the related LISP-IMPLEMENTATION-FOO
;;; functions -- these really can return NIL.
(defknown (machine-type machine-version machine-instance
- software-type software-version
- short-site-name long-site-name)
+ software-type software-version
+ short-site-name long-site-name)
() (or simple-string null) (flushable))
(defknown identity (t) t (movable foldable flushable unsafe)
(defknown sb!impl::signal-bounding-indices-bad-error
(sequence index sequence-end)
nil) ; never returns
-
+
(defknown arg-count-error (t t t t t t) nil (unsafe))
\f
(defun %def-reffer (name offset lowtag)
(let ((fun-info (fun-info-or-lose name)))
(setf (fun-info-ir2-convert fun-info)
- (lambda (node block)
- (ir2-convert-reffer node block name offset lowtag))))
+ (lambda (node block)
+ (ir2-convert-reffer node block name offset lowtag))))
name)
(defun %def-setter (name offset lowtag)
(let ((fun-info (fun-info-or-lose name)))
(setf (fun-info-ir2-convert fun-info)
- (if (listp name)
- (lambda (node block)
- (ir2-convert-setfer node block name offset lowtag))
- (lambda (node block)
- (ir2-convert-setter node block name offset lowtag)))))
+ (if (listp name)
+ (lambda (node block)
+ (ir2-convert-setfer node block name offset lowtag))
+ (lambda (node block)
+ (ir2-convert-setter node block name offset lowtag)))))
name)
(defun %def-alloc (name words variable-length-p header lowtag inits)
(let ((info (fun-info-or-lose name)))
(setf (fun-info-ir2-convert info)
- (if variable-length-p
- (lambda (node block)
- (ir2-convert-variable-allocation node block name words header
- lowtag inits))
- (lambda (node block)
- (ir2-convert-fixed-allocation node block name words header
- lowtag inits)))))
+ (if variable-length-p
+ (lambda (node block)
+ (ir2-convert-variable-allocation node block name words header
+ lowtag inits))
+ (lambda (node block)
+ (ir2-convert-fixed-allocation node block name words header
+ lowtag inits)))))
name)
;;; 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.45"
+"0.9.2.46"
projects / sbcl.git / commitdiff