From c2431e2d0d0222a3cf20cfdfa48201bdcc65cd76 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 14 Jul 2005 18:52:36 +0000 Subject: [PATCH] 0.9.2.46: another slice of whitespace canonicalization (Anyone who ends up here with "cvs annotate" probably wants to look at the "tabby" tagged version.) --- src/compiler/aliencomp.lisp | 496 ++++++------ src/compiler/array-tran.lisp | 688 ++++++++-------- src/compiler/assem.lisp | 1656 +++++++++++++++++++------------------- src/compiler/backend.lisp | 64 +- src/compiler/bit-util.lisp | 6 +- src/compiler/checkgen.lisp | 168 ++-- src/compiler/codegen.lisp | 102 +-- src/compiler/compiler-error.lisp | 16 +- src/compiler/constraint.lisp | 300 +++---- src/compiler/control.lisp | 134 +-- src/compiler/copyprop.lisp | 140 ++-- src/compiler/ctype.lisp | 578 ++++++------- src/compiler/debug-dump.lisp | 568 ++++++------- src/compiler/debug.lisp | 784 +++++++++--------- src/compiler/defconstant.lisp | 30 +- src/compiler/deftype.lisp | 12 +- src/compiler/dfo.lisp | 366 ++++----- src/compiler/disassem.lisp | 358 ++++---- src/compiler/dump.lisp | 870 ++++++++++---------- src/compiler/early-c.lisp | 12 +- src/compiler/entry.lisp | 56 +- src/compiler/fixup-type.lisp | 4 +- src/compiler/fixup.lisp | 36 +- src/compiler/float-tran.lisp | 1214 ++++++++++++++-------------- src/compiler/fndb.lisp | 256 +++--- src/compiler/fun-info-funs.lisp | 28 +- version.lisp-expr | 2 +- 27 files changed, 4472 insertions(+), 4472 deletions(-) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 89771f2..92a9128 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -72,15 +72,15 @@ ;;;; 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)) ;;;; SLOT support @@ -94,62 +94,62 @@ (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) @@ -157,7 +157,7 @@ (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)))) ;;;; DEREF support @@ -167,8 +167,8 @@ (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))) @@ -185,48 +185,48 @@ (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)) @@ -241,8 +241,8 @@ (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)) @@ -250,10 +250,10 @@ (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) @@ -261,17 +261,17 @@ (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) @@ -280,7 +280,7 @@ (/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))))) ;;;; support for aliens on the heap @@ -289,15 +289,15 @@ (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) @@ -309,10 +309,10 @@ (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) @@ -323,8 +323,8 @@ (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) @@ -338,8 +338,8 @@ (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) @@ -347,25 +347,25 @@ (/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 @@ -377,24 +377,24 @@ (/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) @@ -406,49 +406,49 @@ (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))) ;;;; %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) @@ -457,11 +457,11 @@ "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))))) ;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc. @@ -471,8 +471,8 @@ (combination (extract-fun-args alien '%sap-alien 2) '(lambda (sap type) - (declare (ignore type)) - sap)) + (declare (ignore type)) + sap)) (t (give-up-ir1-transform))))) @@ -492,16 +492,16 @@ ;;;; 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) @@ -517,43 +517,43 @@ (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 @@ -564,12 +564,12 @@ (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)) @@ -601,8 +601,8 @@ ;;;; 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) @@ -615,35 +615,35 @@ (/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)) @@ -657,7 +657,7 @@ (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) @@ -665,48 +665,48 @@ (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)))) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 2423b82..0af3b83 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -18,11 +18,11 @@ ;;; 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. @@ -34,18 +34,18 @@ ;; 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 @@ -73,7 +73,7 @@ (declare (type (or lvar null) arg)) (or (not arg) (and (constant-lvar-p arg) - (not (lvar-value arg))))) + (not (lvar-value arg))))) ;;;; DERIVE-TYPE optimizers @@ -128,29 +128,29 @@ (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)) '(*)) @@ -182,85 +182,85 @@ ;;; 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 @@ -268,27 +268,27 @@ ;;; :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)) @@ -305,29 +305,29 @@ ;; 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 @@ -340,7 +340,7 @@ ;;; %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.")) @@ -353,35 +353,35 @@ "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)))))) ;;;; miscellaneous properties of arrays @@ -400,9 +400,9 @@ ;; 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)))) @@ -413,9 +413,9 @@ (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))) @@ -424,52 +424,52 @@ (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 @@ -485,9 +485,9 @@ (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. @@ -496,32 +496,32 @@ ;;; 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 @@ -561,160 +561,160 @@ ;;; 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))) ;;;; 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)) @@ -730,18 +730,18 @@ (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)) ;;;; bit-vector array operation canonicalization ;;;; @@ -753,7 +753,7 @@ (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 @@ -775,19 +775,19 @@ ;;; 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)) ;;; 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))) diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 3dd4a95..3745ef1 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -32,10 +32,10 @@ ;; 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. @@ -73,9 +73,9 @@ ;; 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. @@ -124,7 +124,7 @@ (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 @@ -155,18 +155,18 @@ ;;; 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))))) ;;;; structures/types used by the scheduler @@ -186,10 +186,10 @@ 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)) @@ -221,18 +221,18 @@ (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) - '))) + #!+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) + '))) (when (inst-depth inst) (format stream ", depth=~W" (inst-depth inst))))) @@ -244,7 +244,7 @@ ;;;; 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 @@ -252,87 +252,87 @@ ;; 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 @@ -342,34 +342,34 @@ (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 @@ -382,78 +382,78 @@ ;; 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 @@ -463,79 +463,79 @@ ;; 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. @@ -554,7 +554,7 @@ ;;; 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)) @@ -570,36 +570,36 @@ ((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. @@ -615,23 +615,23 @@ (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 @@ -640,14 +640,14 @@ (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 @@ -658,43 +658,43 @@ (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)) ;;;; 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 @@ -705,8 +705,8 @@ ;;; 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 @@ -717,9 +717,9 @@ ;;; 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) @@ -736,8 +736,8 @@ ;;; 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)) @@ -749,14 +749,14 @@ (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)) @@ -766,17 +766,17 @@ ;;; 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 @@ -806,7 +806,7 @@ ;;; 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) @@ -825,16 +825,16 @@ (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 @@ -843,9 +843,9 @@ (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)) @@ -874,32 +874,32 @@ (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. @@ -927,88 +927,88 @@ (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)) @@ -1017,35 +1017,35 @@ (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)) @@ -1054,33 +1054,33 @@ ;;; 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))))))) ;;;; interface to the rest of the compiler @@ -1134,107 +1134,107 @@ ;;; 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. @@ -1265,8 +1265,8 @@ 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 @@ -1280,28 +1280,28 @@ (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) @@ -1339,15 +1339,15 @@ (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)) @@ -1357,10 +1357,10 @@ (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)) ;;;; interface to the instruction set definition @@ -1371,317 +1371,317 @@ (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) diff --git a/src/compiler/backend.lisp b/src/compiler/backend.lisp index 915dec0..6449246 100644 --- a/src/compiler/backend.lisp +++ b/src/compiler/backend.lisp @@ -60,10 +60,10 @@ (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 @@ -117,9 +117,9 @@ (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 @@ -143,24 +143,24 @@ (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 @@ -205,17 +205,17 @@ (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)) @@ -242,9 +242,9 @@ SPARC code in CMUCL, (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 diff --git a/src/compiler/bit-util.lisp b/src/compiler/bit-util.lisp index 10d540c..0bc7498 100644 --- a/src/compiler/bit-util.lisp +++ b/src/compiler/bit-util.lisp @@ -14,7 +14,7 @@ #!-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) @@ -25,8 +25,8 @@ ;;; 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 diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index ddad0b6..c70fb35 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -27,15 +27,15 @@ (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 @@ -48,34 +48,34 @@ (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 @@ -136,11 +136,11 @@ (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) @@ -194,7 +194,7 @@ ;;; 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). ;;; @@ -330,35 +330,35 @@ (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 @@ -398,11 +398,11 @@ (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 @@ -439,17 +439,17 @@ 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, @@ -485,7 +485,7 @@ (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) @@ -496,7 +496,7 @@ ;; 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) diff --git a/src/compiler/codegen.lisp b/src/compiler/codegen.lisp index 7a17680..2eafcda 100644 --- a/src/compiler/codegen.lisp +++ b/src/compiler/codegen.lisp @@ -18,10 +18,10 @@ ;;; 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. @@ -36,8 +36,8 @@ (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 @@ -72,10 +72,10 @@ (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 @@ -92,68 +92,68 @@ ;;; 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*) @@ -162,7 +162,7 @@ (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)))) diff --git a/src/compiler/compiler-error.lisp b/src/compiler/compiler-error.lisp index a9b6ef5..d2fbbfb 100644 --- a/src/compiler/compiler-error.lisp +++ b/src/compiler/compiler-error.lisp @@ -82,7 +82,7 @@ ;;; 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). @@ -140,13 +140,13 @@ (;; 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))))) diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index ebe39ca..60e0a7b 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -48,9 +48,9 @@ (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 @@ -80,35 +80,35 @@ ;;; 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. @@ -117,7 +117,7 @@ (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, @@ -138,20 +138,20 @@ (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) @@ -165,7 +165,7 @@ (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) @@ -222,8 +222,8 @@ (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)) @@ -248,21 +248,21 @@ (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) @@ -282,48 +282,48 @@ 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 @@ -333,44 +333,44 @@ (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)) @@ -455,19 +455,19 @@ (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: @@ -510,7 +510,7 @@ ;;; 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))) @@ -542,14 +542,14 @@ (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) diff --git a/src/compiler/control.lisp b/src/compiler/control.lisp index 2e1db87..6d3b5f5 100644 --- a/src/compiler/control.lisp +++ b/src/compiler/control.lisp @@ -50,30 +50,30 @@ (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)))) @@ -104,28 +104,28 @@ (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 @@ -143,28 +143,28 @@ (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 @@ -179,11 +179,11 @@ (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) @@ -193,21 +193,21 @@ (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)) diff --git a/src/compiler/copyprop.lisp b/src/compiler/copyprop.lisp index eefacbd..5a4e941 100644 --- a/src/compiler/copyprop.lisp +++ b/src/compiler/copyprop.lisp @@ -71,19 +71,19 @@ (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? @@ -95,7 +95,7 @@ (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 @@ -105,26 +105,26 @@ (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)) @@ -137,13 +137,13 @@ (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.") @@ -154,19 +154,19 @@ ;;; 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 @@ -207,31 +207,31 @@ (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)) @@ -246,8 +246,8 @@ (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))) diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 6d02818..32ed243 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -106,13 +106,13 @@ ((: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)) @@ -191,35 +191,35 @@ ((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 @@ -231,9 +231,9 @@ (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)) @@ -252,20 +252,20 @@ (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. @@ -279,34 +279,34 @@ :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)))))))) ;;;; approximate function types ;;;; @@ -324,9 +324,9 @@ ;; 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) @@ -344,7 +344,7 @@ ;; 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 @@ -355,126 +355,126 @@ ;;; 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 - "~:@" - 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 - "~:@" - call-max max-args)) - ((and keyp (oddp (- call-max max-args))) - (note-lossage - "~:@"))) (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)) @@ -488,25 +488,25 @@ ;;; 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 @@ -518,29 +518,29 @@ ;;; 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))))))) ;;;; ASSERT-DEFINITION-TYPE @@ -551,19 +551,19 @@ (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 @@ -593,89 +593,89 @@ ;;; 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)))) @@ -684,23 +684,23 @@ (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 @@ -720,24 +720,24 @@ 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 @@ -832,8 +832,8 @@ (compiler-style-warn "~@" - (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)) @@ -854,7 +854,7 @@ (dtype (lvar-value dtype))) (unless (eq atype nil) (warn 'type-warning - :format-control - "~@" - :format-arguments (list atype dtype))))) + :format-control + "~@" + :format-arguments (list atype dtype))))) (ir2-convert-full-call node block))) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 0dc56c3..b098797 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -20,13 +20,13 @@ (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. @@ -39,11 +39,11 @@ ;;; 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)) @@ -58,25 +58,25 @@ ;;; 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. @@ -89,15 +89,15 @@ ;;; 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)))) @@ -110,7 +110,7 @@ (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)) @@ -118,16 +118,16 @@ ;;; 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 @@ -138,36 +138,36 @@ (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)) @@ -177,23 +177,23 @@ (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 @@ -201,75 +201,75 @@ ;;; 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))) ;;; 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 @@ -282,40 +282,40 @@ (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 (*))))))) ;;;; variables @@ -323,7 +323,7 @@ (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 @@ -336,22 +336,22 @@ ;;; 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))) @@ -361,10 +361,10 @@ (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)) @@ -378,42 +378,42 @@ (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 @@ -431,10 +431,10 @@ (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)))) ;;;; arguments/returns @@ -450,31 +450,31 @@ (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)))) @@ -483,8 +483,8 @@ (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)))))) ;;;; debug functions @@ -492,9 +492,9 @@ (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)) @@ -509,42 +509,42 @@ (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)) ;;;; full component dumping @@ -553,15 +553,15 @@ (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 @@ -569,20 +569,20 @@ (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)))) ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of ;;; BITS must be evenly divisible by eight. @@ -594,18 +594,18 @@ (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)) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 872144a..e3c665b 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -25,12 +25,12 @@ (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 @@ -83,30 +83,30 @@ (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)))) |# )) @@ -114,40 +114,40 @@ (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)) @@ -176,9 +176,9 @@ (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) @@ -187,7 +187,7 @@ (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 @@ -199,19 +199,19 @@ :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))) @@ -219,11 +219,11 @@ ((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 @@ -234,11 +234,11 @@ (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) @@ -246,7 +246,7 @@ (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) @@ -254,22 +254,22 @@ (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))))) ;;;; loop consistency checking @@ -283,7 +283,7 @@ (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)) @@ -312,10 +312,10 @@ (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)) @@ -335,9 +335,9 @@ (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) @@ -355,13 +355,13 @@ (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)) @@ -374,22 +374,22 @@ (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)) @@ -399,43 +399,43 @@ (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)) ;;;; node consistency checking @@ -462,12 +462,12 @@ (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) @@ -506,11 +506,11 @@ (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) @@ -531,19 +531,19 @@ (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)) @@ -558,32 +558,32 @@ (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 @@ -602,13 +602,13 @@ (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 @@ -619,11 +619,11 @@ (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)) @@ -633,21 +633,21 @@ (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 @@ -669,41 +669,41 @@ (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 @@ -718,99 +718,99 @@ ;;; 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 @@ -819,24 +819,24 @@ (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, @@ -851,22 +851,22 @@ (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)) ;;;; data structure dumping routines @@ -882,21 +882,21 @@ ;;; 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) @@ -1044,10 +1044,10 @@ (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))))) @@ -1057,17 +1057,17 @@ (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. @@ -1080,9 +1080,9 @@ (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 "=> ") @@ -1118,7 +1118,7 @@ (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)) @@ -1150,12 +1150,12 @@ (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)) @@ -1164,7 +1164,7 @@ (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)) @@ -1174,12 +1174,12 @@ (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. @@ -1194,10 +1194,10 @@ (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))) @@ -1207,47 +1207,47 @@ (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-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)))) diff --git a/src/compiler/defconstant.lisp b/src/compiler/defconstant.lisp index c70e927..403db52 100644 --- a/src/compiler/defconstant.lisp +++ b/src/compiler/defconstant.lisp @@ -26,7 +26,7 @@ (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 @@ -39,17 +39,17 @@ the usual naming convention (names like *FOO*) for special variables" ;; 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.) @@ -75,14 +75,14 @@ the usual naming convention (names like *FOO*) for special variables" ;; 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 @@ -110,5 +110,5 @@ the usual naming convention (names like *FOO*) for special variables" (eval `(defconstant ,name ',value)))) (setf (info :variable :kind name) :constant - (info :variable :constant-value name) value) + (info :variable :constant-value name) value) name) diff --git a/src/compiler/deftype.lisp b/src/compiler/deftype.lisp index 752f878..8c266b3 100644 --- a/src/compiler/deftype.lisp +++ b/src/compiler/deftype.lisp @@ -16,10 +16,10 @@ (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))))))) diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index a4fca7f..763d929 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -21,16 +21,16 @@ (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)) @@ -43,33 +43,33 @@ (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)) @@ -128,15 +128,15 @@ (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 @@ -156,18 +156,18 @@ (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). @@ -187,14 +187,14 @@ (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 @@ -237,8 +237,8 @@ (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) @@ -250,55 +250,55 @@ (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. @@ -306,8 +306,8 @@ (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 @@ -319,41 +319,41 @@ (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)))) @@ -379,43 +379,43 @@ ;; 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 "". + (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 "". (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)))) @@ -431,49 +431,49 @@ (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. @@ -487,7 +487,7 @@ ;; 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))))) @@ -498,22 +498,22 @@ (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))) diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index 588c19c..a5165fe 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -53,9 +53,9 @@ ;;; 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 @@ -310,7 +310,7 @@ (defvar *disassem-fun-cache* (make-fun-cache)) (defstruct (arg (:copier nil) - (:predicate nil)) + (:predicate nil)) (name nil :type symbol) (fields nil :type list) @@ -352,16 +352,16 @@ (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) @@ -435,8 +435,8 @@ (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* @@ -469,19 +469,19 @@ (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 @@ -498,8 +498,8 @@ (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) @@ -507,9 +507,9 @@ (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 @@ -655,9 +655,9 @@ (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 @@ -684,7 +684,7 @@ (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)) @@ -708,19 +708,19 @@ arg-name)) (setf (arg-fields arg) (mapcar (lambda (bytespec) - (when (> (+ (byte-position bytespec) - (byte-size bytespec)) - format-length) - (error "~@ (+ (byte-position bytespec) + (byte-size bytespec)) + format-length) + (error "~@" - 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)) @@ -769,7 +769,7 @@ (push `(,(cadr atk) ,(cddr atk)) bindings)) (t (mapc (lambda (var form) - (push `(,var ,form) bindings)) + (push `(,var ,form) bindings)) (cadr atk) (cddr atk)))))) bindings)) @@ -838,17 +838,17 @@ ;;; ;;; :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 @@ -871,34 +871,34 @@ (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) @@ -908,72 +908,72 @@ (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)) @@ -1001,7 +1001,7 @@ thing)) (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))) @@ -1015,19 +1015,19 @@ (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 @@ -1035,8 +1035,8 @@ (,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) @@ -1049,15 +1049,15 @@ (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))))) (defun make-printer-defun (source funstate fun-name) (let ((printer-form (compile-printer-list source funstate)) @@ -1138,7 +1138,7 @@ key (sharing-mapcar (lambda (sub-test) - (preprocess-test subj sub-test args)) + (preprocess-test subj sub-test args)) body)))) (t form))))) @@ -1163,23 +1163,23 @@ :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 @@ -1309,12 +1309,12 @@ `(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 @@ -1398,7 +1398,7 @@ (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: ~ @@ -1458,16 +1458,16 @@ (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) @@ -1571,47 +1571,47 @@ ;;; 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) @@ -1621,19 +1621,19 @@ (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. ;;; diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 6bfc35c..1ad330c 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -21,12 +21,12 @@ ;;; 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 @@ -145,15 +145,15 @@ ;;; 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 @@ -163,13 +163,13 @@ ;;; 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) @@ -271,20 +271,20 @@ ;;; 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. @@ -296,34 +296,34 @@ (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)) @@ -334,7 +334,7 @@ (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. @@ -354,53 +354,53 @@ (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 @@ -413,17 +413,17 @@ ;;; 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 @@ -435,15 +435,15 @@ (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)) @@ -463,12 +463,12 @@ (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))) ;;;; LOAD-TIME-VALUE and MAKE-LOAD-FORM support @@ -478,7 +478,7 @@ (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) @@ -489,7 +489,7 @@ ;;; 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)) @@ -593,24 +593,24 @@ (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)))) ;;; dumper for lists @@ -633,43 +633,43 @@ ;;; 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)) @@ -683,12 +683,12 @@ (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. @@ -705,17 +705,17 @@ (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))))))) ;;;; array dumping @@ -730,10 +730,10 @@ ;;; 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 @@ -743,14 +743,14 @@ #-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 @@ -790,17 +790,17 @@ ((= 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 @@ -820,76 +820,76 @@ (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) (*)) @@ -897,18 +897,18 @@ #!+#.(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))) @@ -956,44 +956,44 @@ (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 @@ -1002,7 +1002,7 @@ (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))) @@ -1012,9 +1012,9 @@ (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 @@ -1030,40 +1030,40 @@ (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)) @@ -1081,24 +1081,24 @@ ;;; ;;; 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)) @@ -1114,49 +1114,49 @@ ;; 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. @@ -1171,11 +1171,11 @@ (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) @@ -1197,7 +1197,7 @@ ;;; 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) @@ -1220,11 +1220,11 @@ ;;; 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)) @@ -1238,31 +1238,31 @@ (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)) @@ -1287,7 +1287,7 @@ (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 @@ -1295,15 +1295,15 @@ (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)) @@ -1313,36 +1313,36 @@ (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)) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 2d2444f..515701a 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -138,7 +138,7 @@ (defvar *object-id-counter* 0) (defun new-object-id () (prog1 - *object-id-counter* + *object-id-counter* (incf *object-id-counter*)))) ;;;; miscellaneous utilities @@ -147,16 +147,16 @@ ;;; 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 diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 5f955ee..8495698 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -24,10 +24,10 @@ (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)) @@ -35,14 +35,14 @@ (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))) @@ -70,28 +70,28 @@ (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)) diff --git a/src/compiler/fixup-type.lisp b/src/compiler/fixup-type.lisp index ca3406c..6cfd887 100644 --- a/src/compiler/fixup-type.lisp +++ b/src/compiler/fixup-type.lisp @@ -5,8 +5,8 @@ (!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 diff --git a/src/compiler/fixup.lisp b/src/compiler/fixup.lisp index 1a5e064..2e98849 100644 --- a/src/compiler/fixup.lisp +++ b/src/compiler/fixup.lisp @@ -14,8 +14,8 @@ ;;; 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. @@ -29,8 +29,8 @@ 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) @@ -45,18 +45,18 @@ ;;; 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)) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 9e6033c..8a3a055 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -37,10 +37,10 @@ ;;; 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)) @@ -50,17 +50,17 @@ ;;; 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) @@ -76,7 +76,7 @@ (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 @@ -85,7 +85,7 @@ ((> 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*)) @@ -115,19 +115,19 @@ (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))) ;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, and SCALE-FLOAT @@ -168,15 +168,15 @@ (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))) @@ -222,45 +222,45 @@ (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 @@ -269,23 +269,23 @@ (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 ;;;; float contagion @@ -305,9 +305,9 @@ (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 @@ -315,17 +315,17 @@ ;;; 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 =)) @@ -336,33 +336,33 @@ ;;; 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))) ;;;; 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) @@ -372,7 +372,7 @@ (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) @@ -402,7 +402,7 @@ (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) @@ -501,16 +501,16 @@ (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)) @@ -527,8 +527,8 @@ (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 @@ -543,9 +543,9 @@ (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 @@ -554,13 +554,13 @@ (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 @@ -569,43 +569,43 @@ ;; 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)) @@ -626,71 +626,71 @@ ;;; 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) @@ -728,25 +728,25 @@ ;; 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) @@ -755,28 +755,28 @@ ;; 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 @@ -784,160 +784,160 @@ (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)) @@ -949,13 +949,13 @@ (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)) @@ -971,21 +971,21 @@ ;; 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 @@ -1005,47 +1005,47 @@ (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)) @@ -1061,48 +1061,48 @@ ;;; 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)) @@ -1110,19 +1110,19 @@ (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. @@ -1132,17 +1132,17 @@ ;; 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.) @@ -1154,71 +1154,71 @@ ;;; 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)) @@ -1231,42 +1231,42 @@ #-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 @@ -1286,10 +1286,10 @@ (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)) @@ -1298,31 +1298,31 @@ (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)) @@ -1337,13 +1337,13 @@ ;;;; 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)) @@ -1362,22 +1362,22 @@ (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 @@ -1389,9 +1389,9 @@ (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) @@ -1399,35 +1399,35 @@ ((>= 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)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 8291da9..704e7f0 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -29,7 +29,7 @@ ;;; 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)) ;;;; from the "Predicates" chapter: @@ -69,9 +69,9 @@ (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)) @@ -165,18 +165,18 @@ (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... ;;;; 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)) @@ -195,7 +195,7 @@ (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)) @@ -333,8 +333,8 @@ (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)) @@ -345,7 +345,7 @@ (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 @@ -384,14 +384,14 @@ ;;;; 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)) @@ -435,8 +435,8 @@ :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)) @@ -472,13 +472,13 @@ ;;; 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)) @@ -487,12 +487,12 @@ :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) @@ -514,7 +514,7 @@ (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)) @@ -544,7 +544,7 @@ (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)) @@ -558,59 +558,59 @@ (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)) @@ -623,23 +623,23 @@ (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)) @@ -697,19 +697,19 @@ (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)) @@ -717,7 +717,7 @@ (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) @@ -739,10 +739,10 @@ (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)) @@ -776,14 +776,14 @@ ;;;; 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)) @@ -808,7 +808,7 @@ (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) () @@ -831,9 +831,9 @@ (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... @@ -844,20 +844,20 @@ (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) @@ -902,9 +902,9 @@ (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)) @@ -989,8 +989,8 @@ (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)) @@ -999,17 +999,17 @@ (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)) @@ -1036,8 +1036,8 @@ (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) @@ -1072,8 +1072,8 @@ (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)) @@ -1088,18 +1088,18 @@ ;;; 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 ()) @@ -1116,10 +1116,10 @@ (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) ()) @@ -1141,19 +1141,19 @@ (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)) @@ -1170,13 +1170,13 @@ (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) @@ -1189,7 +1189,7 @@ ()) (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)) @@ -1246,9 +1246,9 @@ ;; 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) @@ -1261,7 +1261,7 @@ ;; 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) @@ -1281,15 +1281,15 @@ (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 @@ -1314,8 +1314,8 @@ ;;; 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) @@ -1420,7 +1420,7 @@ (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)) diff --git a/src/compiler/fun-info-funs.lisp b/src/compiler/fun-info-funs.lisp index 6c7c63d..a5b6290 100644 --- a/src/compiler/fun-info-funs.lisp +++ b/src/compiler/fun-info-funs.lisp @@ -9,28 +9,28 @@ (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) diff --git a/version.lisp-expr b/version.lisp-expr index d3c5b0c..62f23be 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4