mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Remove #+vop-something reader syntax
This commit is contained in:
Douglas Katzman
parent
0e35dc1b83
commit
30b7b2ef26
|
|
@ -151,12 +151,10 @@
|
|||
#+ecl (proclaim '(optimize (safety 2) (debug 2)))
|
||||
|
||||
(maybe-with-compilation-unit
|
||||
(let ((*feature-evaluation-results* nil))
|
||||
;; If make-host-1 is parallelized, it will produce host fasls without loading
|
||||
;; them. The host will have interpreted definitions of most everything,
|
||||
;; which is OK because writing out the C headers is not compute-intensive.
|
||||
(load-or-cload-xcompiler #'host-cload-stem)
|
||||
(write-feature-eval-results))
|
||||
;; propagate structure offset and other information to the C runtime
|
||||
;; support code.
|
||||
(load "tools-for-build/corefile.lisp" :verbose nil)
|
||||
|
|
|
|||
|
|
@ -25,9 +25,7 @@
|
|||
functions
|
||||
types)
|
||||
(sb-xc:with-compilation-unit ()
|
||||
(let ((*feature-evaluation-results* nil))
|
||||
(load "src/cold/compile-cold-sbcl.lisp")
|
||||
(sanity-check-feature-evaluation))
|
||||
(load "src/cold/compile-cold-sbcl.lisp")
|
||||
;; Enforce absence of unexpected forward-references to warm loaded code.
|
||||
;; Looking into a hidden detail of this compiler seems fair game.
|
||||
(when (and sb-c::*undefined-warnings*
|
||||
|
|
|
|||
|
|
@ -439,8 +439,7 @@
|
|||
(setf (%array-displaced-from old-data)
|
||||
(purge (%array-displaced-from old-data)))))))
|
||||
|
||||
#-(vop-translates sb-kernel:set-header-bits)
|
||||
(progn
|
||||
(sb-c::unless-vop-existsp (:translate set-header-bits)
|
||||
(declaim (inline set-header-bits unset-header-bits))
|
||||
(defun set-header-bits (vector bits)
|
||||
(set-header-data vector (logior (get-header-data vector) bits))
|
||||
|
|
|
|||
|
|
@ -11,33 +11,19 @@
|
|||
|
||||
(in-package "SB-THREAD")
|
||||
|
||||
|
||||
;;;; Interpreter stubs for the various barrier functions
|
||||
|
||||
;;; If no memory barrier vops exist, then the %{mumble}-BARRIER function is an inline
|
||||
;;; function that does nothing. If the vops exist, then the same function
|
||||
;;; is always translated with a vop, and the DEFUN is merely an interpreter stub.
|
||||
#-(vop-named sb-vm:%memory-barrier)
|
||||
(progn
|
||||
;;; Assert correctness of build order. (Need not be exhaustive)
|
||||
(eval-when (:compile-toplevel) #+x86-64 (error "Expected %memory-barrier vop"))
|
||||
(declaim (inline sb-vm:%compiler-barrier sb-vm:%memory-barrier
|
||||
sb-vm:%read-barrier sb-vm:%write-barrier
|
||||
sb-vm:%data-dependency-barrier)))
|
||||
|
||||
;;; Because of cross-compiler madness, avoid defining inline functions
|
||||
;;; inside a macrolet.
|
||||
;;; TODO: fix that problem once and for all, and put this back into a less insane form.
|
||||
(progn
|
||||
.
|
||||
#.(loop for name in '(sb-vm:%compiler-barrier
|
||||
sb-vm:%memory-barrier
|
||||
sb-vm:%read-barrier
|
||||
sb-vm:%write-barrier
|
||||
sb-vm:%data-dependency-barrier)
|
||||
collect `(defun ,name ()
|
||||
#+(vop-named sb-vm:%memory-barrier) (,name)
|
||||
(values))))
|
||||
(eval-when (:compile-toplevel)
|
||||
(sb-xc:defmacro def-barrier (name)
|
||||
(if (sb-c::vop-existsp :named sb-vm:%memory-barrier)
|
||||
`(defun ,name () (,name))
|
||||
`(progn (declaim (inline ,name)) (defun ,name () (values))))))
|
||||
(def-barrier sb-vm:%compiler-barrier)
|
||||
(def-barrier sb-vm:%memory-barrier)
|
||||
(def-barrier sb-vm:%read-barrier)
|
||||
(def-barrier sb-vm:%write-barrier)
|
||||
(def-barrier sb-vm:%data-dependency-barrier)
|
||||
|
||||
;;;; The actual barrier macro and support
|
||||
(defmacro barrier ((kind) &body forms)
|
||||
|
|
|
|||
|
|
@ -1479,9 +1479,9 @@ symbol-case giving up: case=((V U) (F))
|
|||
(setq clauses (if default (cons default new-clauses) new-clauses)
|
||||
keys (new-keys)
|
||||
implement-as 'case))
|
||||
#+(vop-named sb-c:multiway-branch-if-eq)
|
||||
((expand-struct-typecase keyform keyform-value normal-clauses keys
|
||||
default errorp)
|
||||
((and (sb-c::vop-existsp :named sb-c:multiway-branch-if-eq)
|
||||
(expand-struct-typecase keyform keyform-value normal-clauses keys
|
||||
default errorp))
|
||||
(return-from case-body-aux it))))))
|
||||
|
||||
;; Efficiently expanding CASE over symbols depends on CASE over integers being
|
||||
|
|
|
|||
|
|
@ -204,12 +204,11 @@ distinct from the global value. Can also be SETF."
|
|||
|
||||
(defun symbol-plist (symbol)
|
||||
"Return SYMBOL's property list."
|
||||
#+(vop-translates cl:symbol-plist)
|
||||
(symbol-plist symbol)
|
||||
#-(vop-translates cl:symbol-plist)
|
||||
(let ((list (car (truly-the list (symbol-info symbol))))) ; a harmless lie
|
||||
;; Just ensure the result is not a fixnum, and we're done.
|
||||
(if (fixnump list) nil list)))
|
||||
(if (sb-c::vop-existsp :translate cl:symbol-plist)
|
||||
(symbol-plist symbol)
|
||||
(let ((list (car (truly-the list (symbol-info symbol))))) ; a harmless lie
|
||||
;; Just ensure the result is not a fixnum, and we're done.
|
||||
(if (fixnump list) nil list))))
|
||||
|
||||
(declaim (ftype (sfunction (symbol t) cons) %ensure-plist-holder)
|
||||
(inline %ensure-plist-holder))
|
||||
|
|
|
|||
|
|
@ -2426,7 +2426,7 @@ mechanism for inter-thread communication."
|
|||
;;; This can not be "corrected" by genesis - there is no TLS when genesis executes.
|
||||
;;; The only way to do this uniformly for all the platforms is to compute the address
|
||||
;;; of the thread-local storage slot, and use (SETF SAP-REF-LISPOBJ) on that.
|
||||
;;; (Nor is #+(vop-translates ensure-symbol-tls-index) a reliable indicator that the
|
||||
;;; (Existence of a vop for ENSURE-SYMBOL-TLS-INDEX is not an indicator that the
|
||||
;;; SET vop will assign into a thread-local symbol that currently has no TLS value.)
|
||||
(defun init-thread-local-storage (thread)
|
||||
;; In addition to wanting the expressly unsafe variant of SYMBOL-VALUE, any error
|
||||
|
|
|
|||
|
|
@ -155,6 +155,7 @@
|
|||
;; Let's check that the type system, and various other things, are
|
||||
;; reasonably sane. (It's easy to spend a long time wandering around
|
||||
;; confused trying to debug cross-compilation if it isn't.)
|
||||
(sb-c::check-vop-existence-correctness)
|
||||
(let ((*readtable* *xc-readtable*)
|
||||
(*load-verbose* t))
|
||||
(with-math-journal
|
||||
|
|
|
|||
|
|
@ -42,50 +42,6 @@
|
|||
(defun backend-asm-package-name ()
|
||||
(concatenate 'string "SB-" (string (backend-assembler-target-name)) "-ASM"))
|
||||
|
||||
(defun any-vop-named-p (vop-name)
|
||||
(let ((ht (symbol-value (find-symbol "*BACKEND-PARSED-VOPS*" "SB-C"))))
|
||||
(not (null (gethash vop-name ht)))))
|
||||
|
||||
(defun any-vop-translates-p (fun-name)
|
||||
(let ((f (intern "INFO" "SB-INT")))
|
||||
(when (fboundp f)
|
||||
(let ((info (funcall f :function :info fun-name)))
|
||||
(if info
|
||||
(let ((f (intern "FUN-INFO-TEMPLATES" "SB-C")))
|
||||
(and (fboundp f) (not (null (funcall f info))))))))))
|
||||
|
||||
(defvar *feature-eval-results-file* "output/feature-tests.lisp-expr")
|
||||
(defvar *feature-evaluation-results*)
|
||||
|
||||
(defun recording-feature-eval (expression value)
|
||||
;; This safety check does not work for parallel build, but that produces
|
||||
;; different code anyway due to missing derived types in any file that would
|
||||
;; have been compiled in the serial order but was interpreted instead.
|
||||
(when (boundp '*feature-evaluation-results*)
|
||||
; (format t "~&FEATURE EXPR: ~S -> ~S~%" expression value)
|
||||
(push (cons expression value) *feature-evaluation-results*))
|
||||
value)
|
||||
|
||||
(defun write-feature-eval-results ()
|
||||
(with-open-file (f *feature-eval-results-file*
|
||||
:direction :output
|
||||
:if-exists :supersede :if-does-not-exist :create)
|
||||
(let ((*print-readably* t))
|
||||
(format f "(~{~S~^~% ~})~%" *feature-evaluation-results*))))
|
||||
|
||||
(defun sanity-check-feature-evaluation ()
|
||||
(flet ((check (phase list)
|
||||
(dolist (x list)
|
||||
(let ((answer
|
||||
(ecase (caar x)
|
||||
(:vop-named (any-vop-named-p (cadar x)))
|
||||
(:vop-translates (any-vop-translates-p (cadar x))))))
|
||||
(unless (eq answer (cdr x))
|
||||
(error "make-host-~D DEFINE-VOP ordering bug:~@
|
||||
~S should be ~S, was ~S at xc time" phase x answer (cdr x)))))))
|
||||
(check 1 (with-open-file (f *feature-eval-results-file*) (read f)))
|
||||
(check 2 *feature-evaluation-results*)))
|
||||
|
||||
;;; We should never call this with a selector of :HOST any more,
|
||||
;;; but I'm keeping it in case of emergency.
|
||||
;;; SB-XC:*FEATURES* might not be bound yet when computing derived features.
|
||||
|
|
@ -101,16 +57,7 @@
|
|||
(:or (some #'subfeature-in-list-p (rest feature)))
|
||||
(:and (every #'subfeature-in-list-p (rest feature)))
|
||||
(:not (destructuring-bind (subexpr) (cdr feature)
|
||||
(not (subfeature-in-list-p subexpr))))
|
||||
((:vop-named :vop-translates)
|
||||
(destructuring-bind (subexpr) (cdr feature)
|
||||
(case (first feature)
|
||||
(:vop-named
|
||||
(recording-feature-eval feature
|
||||
(any-vop-named-p subexpr)))
|
||||
(:vop-translates
|
||||
(recording-feature-eval
|
||||
feature (any-vop-translates-p subexpr)))))))))))
|
||||
(not (subfeature-in-list-p subexpr)))))))))
|
||||
(compile 'featurep)
|
||||
|
||||
(defun read-targ-feature-expr (stream sub-character infix-parameter)
|
||||
|
|
|
|||
|
|
@ -710,7 +710,7 @@
|
|||
(reference-tn-list (remove-if-not #'tn-p (flatten-list arg-tns)) nil))
|
||||
(result-operands
|
||||
(reference-tn-list (remove-if-not #'tn-p result-tns) t)))
|
||||
(cond #+(vop-named sb-vm::call-out-named)
|
||||
(cond #+#.(cl:if (sb-c::vop-existsp :named sb-vm::call-out-named) '(and) '(or))
|
||||
((and (constant-lvar-p function) (stringp (lvar-value function)))
|
||||
(vop* call-out-named call block (arg-operands) (result-operands)
|
||||
(lvar-value function)
|
||||
|
|
|
|||
|
|
@ -1436,10 +1436,9 @@
|
|||
(cond ((and (listp dims) (/= (length dims) 1)) nil) ; dims = * is possibly a vector
|
||||
((eq (conservative-array-type-complexp array-type) nil) nil)
|
||||
(t
|
||||
#+(or x86 x86-64)
|
||||
`(test-header-bit array sb-vm:+array-fill-pointer-p+)
|
||||
#-(or x86 x86-64)
|
||||
`(logtest (get-header-data array) sb-vm:+array-fill-pointer-p+)))))
|
||||
(if (vop-existsp :named test-header-bit)
|
||||
`(test-header-bit array sb-vm:+array-fill-pointer-p+)
|
||||
`(logtest (get-header-data array) sb-vm:+array-fill-pointer-p+))))))
|
||||
|
||||
(deftransform %check-bound ((array dimension index) ((simple-array * (*)) * *))
|
||||
(let ((array-ref (lvar-uses array))
|
||||
|
|
|
|||
|
|
@ -45,10 +45,6 @@
|
|||
(defglobal *backend-sbs* #())
|
||||
(declaim (type simple-vector *backend-sbs*))
|
||||
|
||||
;;; translation from template names to template structures
|
||||
(defglobal *backend-template-names* (make-hash-table)) ; keys are symbols
|
||||
(declaim (type hash-table *backend-template-names*))
|
||||
|
||||
;;; hashtables mapping from SC and SB names to the corresponding structures
|
||||
(defglobal *backend-sc-names* (make-hash-table))
|
||||
(declaim (type hash-table *backend-sc-names*))
|
||||
|
|
|
|||
|
|
@ -92,19 +92,13 @@
|
|||
;;;
|
||||
;;; Define SYMBOL-INFO-VECTOR as an inline function unless a vop translates it.
|
||||
;;; (Inlining occurs first, which would cause the vop not to be used.)
|
||||
;;; Also note that we have to guard the appearance of VOP-TRANSLATES here
|
||||
;;; so that it does not get tested when building the cross-compiler.
|
||||
;;; This was the best way I could see to work around a spurious warning
|
||||
;;; about a wrongly ordered VM definition in make-host-1.
|
||||
;;; The #+/- reader can't see that a VOP-TRANSLATES term is not for the
|
||||
;;; host compiler unless the whole thing is one expression.
|
||||
#-(or sb-xc-host (vop-translates sb-kernel:symbol-info-vector))
|
||||
(progn
|
||||
(declaim (inline symbol-info-vector))
|
||||
(defun symbol-info-vector (symbol)
|
||||
(let ((info-holder (symbol-info symbol)))
|
||||
(truly-the (or null simple-vector)
|
||||
(if (listp info-holder) (cdr info-holder) info-holder)))))
|
||||
#-sb-xc-host
|
||||
(sb-c::unless-vop-existsp (:translate sb-kernel:symbol-info-vector)
|
||||
(declaim (inline symbol-info-vector))
|
||||
(defun symbol-info-vector (symbol)
|
||||
(let ((info-holder (symbol-info symbol)))
|
||||
(truly-the (or null simple-vector)
|
||||
(if (listp info-holder) (cdr info-holder) info-holder)))))
|
||||
|
||||
;;; SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp'
|
||||
;;; But in the host Lisp, there is no such thing as a symbol-info slot.
|
||||
|
|
|
|||
|
|
@ -164,3 +164,65 @@
|
|||
|
||||
(defun null-lexenv-p (lexenv)
|
||||
(not (lexenv-%policy lexenv)))
|
||||
|
||||
|
||||
;;; translation from template names to template structures
|
||||
(defglobal *backend-template-names* (make-hash-table)) ; keys are symbols
|
||||
(declaim (type hash-table *backend-template-names*))
|
||||
|
||||
;;; When compiling the cross-compiler, a %VOP-EXISTS-P result could depend on
|
||||
;;; the build order. Usually it will not, because the decision to use a vop is
|
||||
;;; typically made in a transform, so the query occurs only when a transform runs.
|
||||
;;; However, sometimes the existsp check is performed to decide whether or not
|
||||
;;; to define a function or other transform. In that case the existsp check is
|
||||
;;; sensitive to the order of vop definitions. Such uses will often occur inside
|
||||
;;; a "#." so that the defining form remains toplevel.
|
||||
;;; If called with OPTIMISTIC = T then we're trying to return NIL or T
|
||||
;;; or the EXISTSP macroexpander.
|
||||
#+sb-xc-host
|
||||
(progn
|
||||
(defvar *vop-not-existsp* nil)
|
||||
;;; This function is invoked after compiling the cross-compiler
|
||||
;;; before quitting the image, and when loading it from compiled fasls
|
||||
;;; (because toplevel forms might use %VOP-EXISTSP at any time).
|
||||
(defun check-vop-existence-correctness ()
|
||||
(dolist (entry *vop-not-existsp*)
|
||||
(assert (not (%vop-existsp (car entry) (cdr entry))))))
|
||||
(defun %vop-existsp (name query &optional optimistic)
|
||||
(declare (notinline info fun-info-templates))
|
||||
(let ((answer
|
||||
(not (null (ecase query
|
||||
(:named
|
||||
(gethash name *backend-template-names*))
|
||||
(:translate
|
||||
(awhen (info :function :info name)
|
||||
(fun-info-templates it))))))))
|
||||
;; Negatives won't be stored in the journal in optimistic mode.
|
||||
(when (and (not answer) (not optimistic))
|
||||
(pushnew (cons name query) *vop-not-existsp* :test 'equal))
|
||||
answer)))
|
||||
|
||||
(defmacro vop-existsp (query name)
|
||||
#+sb-xc-host
|
||||
(cond ((%vop-existsp name query t)
|
||||
;;(format t "~&VOP-EXISTSP ~s ~s: Yes~%" name query)
|
||||
t)
|
||||
(t
|
||||
;;(format t "~&VOP-EXISTSP ~s ~s: DEFER~%" name query)
|
||||
`(%vop-existsp ',name ,query)))
|
||||
;; When running the cross-compiler, all the inquiries to VOP-EXISTSP have
|
||||
;; definitive answers, so this never defers.
|
||||
;; We use the version of %VOP-EXISTSP that was built in to the host.
|
||||
#-sb-xc-host
|
||||
(funcall '%vop-existsp name query))
|
||||
|
||||
;;; For situations where you want to write (IF (VOP-EXISTSP ...) (THEN) (ELSE))
|
||||
;;; but at least one of (THEN) or (ELSE) contains code that can't be macroexpanded
|
||||
;;; or compiled, as may occur with (VOP* ...), use a different macro that never
|
||||
;;; defers. Correctness of the result requires that the vop be defined in time.
|
||||
(defmacro if-vop-existsp ((query name) then &optional else)
|
||||
(if (funcall '%vop-existsp name query) then else))
|
||||
(defmacro when-vop-existsp ((query name) &rest body)
|
||||
(if (funcall '%vop-existsp name query) `(progn ,@body)))
|
||||
(defmacro unless-vop-existsp ((query name) &rest body)
|
||||
(if (not (funcall '%vop-existsp name query)) `(progn ,@body)))
|
||||
|
|
|
|||
|
|
@ -147,16 +147,15 @@
|
|||
;;; when given a signaling NaN.
|
||||
(deftransform float-sign ((float &optional float2)
|
||||
(single-float &optional single-float) *)
|
||||
#+(vop-translates sb-kernel:single-float-copysign)
|
||||
(if float2
|
||||
`(single-float-copysign float float2)
|
||||
`(single-float-sign float))
|
||||
#-(vop-translates sb-kernel:single-float-copysign)
|
||||
(if float2
|
||||
(let ((temp (gensym)))
|
||||
`(let ((,temp (abs float2)))
|
||||
(if (minusp (single-float-bits float)) (- ,temp) ,temp)))
|
||||
'(if (minusp (single-float-bits float)) $-1f0 $1f0)))
|
||||
(if (vop-existsp :translate single-float-copysign)
|
||||
(if float2
|
||||
`(single-float-copysign float float2)
|
||||
`(single-float-sign float))
|
||||
(if float2
|
||||
(let ((temp (gensym)))
|
||||
`(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) *)
|
||||
|
|
@ -1227,8 +1226,7 @@
|
|||
;; of whether all the operations below are translated by vops.
|
||||
;; We could be more fine-grained, but it seems reasonable that
|
||||
;; they be implemented on an all-or-none basis.
|
||||
#-(vop-named sb-vm::%negate/complex-double-float)
|
||||
(progn
|
||||
(unless (vop-existsp :named sb-vm::%negate/complex-double-float)
|
||||
;; negation
|
||||
(deftransform %negate ((z) ((complex ,type)) *)
|
||||
'(complex (%negate (realpart z)) (%negate (imagpart z))))
|
||||
|
|
@ -1284,55 +1282,53 @@
|
|||
|
||||
;; Divide two complex numbers.
|
||||
(deftransform / ((x y) ((complex ,type) (complex ,type)) *)
|
||||
#-(vop-translates sb-vm::swap-complex)
|
||||
'(let* ((rx (realpart x))
|
||||
(ix (imagpart x))
|
||||
(ry (realpart y))
|
||||
(iy (imagpart y)))
|
||||
(if (> (abs ry) (abs iy))
|
||||
(let* ((r (/ iy ry))
|
||||
(dn (+ ry (* r iy))))
|
||||
(complex (/ (+ rx (* ix r)) dn)
|
||||
(/ (- ix (* rx r)) dn)))
|
||||
(let* ((r (/ ry iy))
|
||||
(dn (+ iy (* r ry))))
|
||||
(complex (/ (+ (* rx r) ix) dn)
|
||||
(/ (- (* ix r) rx) dn)))))
|
||||
#+(vop-translates sb-vm::swap-complex)
|
||||
`(let* ((cs (conjugate (sb-vm::swap-complex x)))
|
||||
(ry (realpart y))
|
||||
(iy (imagpart y)))
|
||||
(if (> (abs ry) (abs iy))
|
||||
(let* ((r (/ iy ry))
|
||||
(dn (+ ry (* r iy))))
|
||||
(/ (+ x (* cs r)) dn))
|
||||
(let* ((r (/ ry iy))
|
||||
(dn (+ iy (* r ry))))
|
||||
(/ (+ (* x r) cs) dn)))))
|
||||
(if (vop-existsp :translate sb-vm::swap-complex)
|
||||
'(let* ((cs (conjugate (sb-vm::swap-complex x)))
|
||||
(ry (realpart y))
|
||||
(iy (imagpart y)))
|
||||
(if (> (abs ry) (abs iy))
|
||||
(let* ((r (/ iy ry))
|
||||
(dn (+ ry (* r iy))))
|
||||
(/ (+ x (* cs r)) dn))
|
||||
(let* ((r (/ ry iy))
|
||||
(dn (+ iy (* r ry))))
|
||||
(/ (+ (* x r) cs) dn))))
|
||||
'(let* ((rx (realpart x))
|
||||
(ix (imagpart x))
|
||||
(ry (realpart y))
|
||||
(iy (imagpart y)))
|
||||
(if (> (abs ry) (abs iy))
|
||||
(let* ((r (/ iy ry))
|
||||
(dn (+ ry (* r iy))))
|
||||
(complex (/ (+ rx (* ix r)) dn)
|
||||
(/ (- ix (* rx r)) dn)))
|
||||
(let* ((r (/ ry iy))
|
||||
(dn (+ iy (* r ry))))
|
||||
(complex (/ (+ (* rx r) ix) dn)
|
||||
(/ (- (* ix r) rx) dn)))))))
|
||||
;; Divide a real by a complex.
|
||||
(deftransform / ((x y) (,type (complex ,type)) *)
|
||||
#-(vop-translates sb-vm::swap-complex)
|
||||
'(let* ((ry (realpart y))
|
||||
(iy (imagpart y)))
|
||||
(if (> (abs ry) (abs iy))
|
||||
(let* ((r (/ iy ry))
|
||||
(dn (+ ry (* r iy))))
|
||||
(complex (/ x dn)
|
||||
(/ (- (* x r)) dn)))
|
||||
(let* ((r (/ ry iy))
|
||||
(dn (+ iy (* r ry))))
|
||||
(complex (/ (* x r) dn)
|
||||
(/ (- x) dn)))))
|
||||
#+(vop-translates sb-vm::swap-complex)
|
||||
'(let* ((ry (realpart y))
|
||||
(iy (imagpart y)))
|
||||
(if (> (abs ry) (abs iy))
|
||||
(let* ((r (/ iy ry))
|
||||
(dn (+ ry (* r iy))))
|
||||
(/ (complex x (- (* x r))) dn))
|
||||
(let* ((r (/ ry iy))
|
||||
(dn (+ iy (* r ry))))
|
||||
(/ (complex (* x r) (- x)) dn)))))
|
||||
(if (vop-existsp :translate sb-vm::swap-complex)
|
||||
'(let* ((ry (realpart y))
|
||||
(iy (imagpart y)))
|
||||
(if (> (abs ry) (abs iy))
|
||||
(let* ((r (/ iy ry))
|
||||
(dn (+ ry (* r iy))))
|
||||
(/ (complex x (- (* x r))) dn))
|
||||
(let* ((r (/ ry iy))
|
||||
(dn (+ iy (* r ry))))
|
||||
(/ (complex (* x r) (- x)) dn))))
|
||||
'(let* ((ry (realpart y))
|
||||
(iy (imagpart y)))
|
||||
(if (> (abs ry) (abs iy))
|
||||
(let* ((r (/ iy ry))
|
||||
(dn (+ ry (* r iy))))
|
||||
(complex (/ x dn)
|
||||
(/ (- (* x r)) dn)))
|
||||
(let* ((r (/ ry iy))
|
||||
(dn (+ iy (* r ry))))
|
||||
(complex (/ (* x r) dn)
|
||||
(/ (- x) dn)))))))
|
||||
;; CIS
|
||||
(deftransform cis ((z) ((,type)) *)
|
||||
'(complex (cos z) (sin z)))
|
||||
|
|
|
|||
|
|
@ -73,11 +73,6 @@
|
|||
res)
|
||||
(move-lvar-result node block locs lvar)))
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
;; Assert correctness of build order. (Need not be exhaustive)
|
||||
#+(and x86-64 (not (vop-named sb-vm::raw-instance-init/word)))
|
||||
(error "Expected raw-instance-init vops"))
|
||||
|
||||
(defun emit-inits (node block name object lowtag inits args)
|
||||
(let ((unbound-marker-tn nil)
|
||||
(funcallable-instance-tramp-tn nil)
|
||||
|
|
@ -105,7 +100,9 @@
|
|||
(zero-init-p arg))
|
||||
(let ((arg-tn (lvar-tn node block arg)))
|
||||
(macrolet
|
||||
((make-case (&optional rsd-list)
|
||||
((make-case (&aux (rsd-list
|
||||
(if (vop-existsp :named sb-vm::raw-instance-init/word)
|
||||
sb-kernel::*raw-slot-data*)))
|
||||
`(ecase raw-type
|
||||
((t)
|
||||
(vop init-slot node block object arg-tn
|
||||
|
|
@ -115,9 +112,8 @@
|
|||
`(,(sb-kernel::raw-slot-data-raw-type rsd)
|
||||
(vop ,(sb-kernel::raw-slot-data-init-vop rsd)
|
||||
node block object arg-tn slot)))
|
||||
(symbol-value rsd-list)))))
|
||||
(make-case #+(vop-named sb-vm::raw-instance-init/word)
|
||||
sb-kernel::*raw-slot-data*))))))
|
||||
rsd-list))))
|
||||
(make-case))))))
|
||||
(:dd
|
||||
(vop init-slot node block object
|
||||
(emit-constant (sb-kernel::dd-layout-or-lose slot))
|
||||
|
|
|
|||
|
|
@ -693,15 +693,15 @@
|
|||
(values)))
|
||||
|
||||
;;;; transforms for EQL of floating point values
|
||||
#-(vop-named sb-vm::eql/single-float)
|
||||
(unless (vop-existsp :named sb-vm::eql/single-float)
|
||||
(deftransform eql ((x y) (single-float single-float))
|
||||
'(= (single-float-bits x) (single-float-bits y)))
|
||||
'(= (single-float-bits x) (single-float-bits y))))
|
||||
|
||||
#-(vop-named sb-vm::eql/double-float)
|
||||
(unless (vop-existsp :named sb-vm::eql/double-float)
|
||||
(deftransform eql ((x y) (double-float double-float))
|
||||
#-64-bit '(and (= (double-float-low-bits x) (double-float-low-bits y))
|
||||
(= (double-float-high-bits x) (double-float-high-bits y)))
|
||||
#+64-bit '(= (double-float-bits x) (double-float-bits y)))
|
||||
#+64-bit '(= (double-float-bits x) (double-float-bits y))))
|
||||
|
||||
|
||||
;;;; modular functions
|
||||
|
|
|
|||
|
|
@ -1735,17 +1735,16 @@ not stack-allocated LVAR ~S." source-lvar)))))
|
|||
(loop for loc in (ir2-lvar-locs 2lvar)
|
||||
for idx upfrom 0
|
||||
unless (eq (tn-kind loc) :unused)
|
||||
do #+(vop-named sb-vm::more-arg-or-nil)
|
||||
(vop sb-vm::more-arg-or-nil node block
|
||||
(lvar-tn node block context)
|
||||
(lvar-tn node block count)
|
||||
idx
|
||||
loc)
|
||||
#-(vop-named sb-vm::more-arg-or-nil)
|
||||
(vop sb-vm::more-arg node block
|
||||
(lvar-tn node block context)
|
||||
(emit-constant idx)
|
||||
loc)))
|
||||
do (if-vop-existsp (:named sb-vm::more-arg-or-nil)
|
||||
(vop sb-vm::more-arg-or-nil node block
|
||||
(lvar-tn node block context)
|
||||
(lvar-tn node block count)
|
||||
idx
|
||||
loc)
|
||||
(vop sb-vm::more-arg node block
|
||||
(lvar-tn node block context)
|
||||
(emit-constant idx)
|
||||
loc))))
|
||||
(:unknown
|
||||
(let ((locs (ir2-lvar-locs 2lvar)))
|
||||
(vop* %more-arg-values node block
|
||||
|
|
@ -1789,9 +1788,9 @@ not stack-allocated LVAR ~S." source-lvar)))))
|
|||
|
||||
(defoptimizer (%special-unbind ir2-convert) ((&rest symbols) node block)
|
||||
(declare (ignorable symbols))
|
||||
#-(vop-named sb-c:unbind-n) (vop unbind node block)
|
||||
#+(vop-named sb-c:unbind-n) (vop unbind-n node block
|
||||
(mapcar #'lvar-value symbols)))
|
||||
(if-vop-existsp (:named sb-c:unbind-n)
|
||||
(vop unbind-n node block (mapcar #'lvar-value symbols))
|
||||
(vop unbind node block)))
|
||||
|
||||
;;; ### It's not clear that this really belongs in this file, or
|
||||
;;; should really be done this way, but this is the least violation of
|
||||
|
|
|
|||
|
|
@ -484,8 +484,7 @@
|
|||
(:restore-nsp
|
||||
(code `(%primitive set-nsp ,(ref-leaf node))))))))
|
||||
(flet ((coalesce-unbinds (code)
|
||||
code
|
||||
#+(vop-named sb-c:unbind-n)
|
||||
(if (vop-existsp :named sb-c:unbind-n)
|
||||
(loop with cleanup
|
||||
while code
|
||||
do (setf cleanup (pop code))
|
||||
|
|
@ -495,7 +494,8 @@
|
|||
,@(loop while (eq (caar code) '%special-unbind)
|
||||
collect (cadar code)
|
||||
do (pop code)))
|
||||
cleanup))))
|
||||
cleanup))
|
||||
code)))
|
||||
(when (code)
|
||||
(aver (not (node-tail-p (block-last (car pred-blocks)))))
|
||||
(insert-cleanup-code
|
||||
|
|
|
|||
|
|
@ -2546,12 +2546,7 @@
|
|||
|
||||
;;; Rightward ASH
|
||||
|
||||
;;; Assert correctness of build order. (Need not be exhaustive)
|
||||
#-(vop-translates sb-kernel:%ash/right)
|
||||
(eval-when (:compile-toplevel) #+x86-64 (error "Expected %ASH/RIGHT vop"))
|
||||
|
||||
#+(vop-translates sb-kernel:%ash/right)
|
||||
(progn
|
||||
(when-vop-existsp (:translate sb-kernel:%ash/right)
|
||||
(defun %ash/right (integer amount)
|
||||
(ash integer (- amount)))
|
||||
|
||||
|
|
@ -2938,10 +2933,7 @@
|
|||
`(ash (%multiply-high (logandc2 x ,(1- (ash 1 shift1))) ,m)
|
||||
,(- (+ shift1 shift2)))))))))
|
||||
|
||||
#-(vop-translates sb-kernel:%multiply-high)
|
||||
(progn
|
||||
;;; Assert correctness of build order. (Need not be exhaustive)
|
||||
(eval-when (:compile-toplevel) #+x86-64 (error "Expected %MULTIPLY-HIGH vop"))
|
||||
(unless-vop-existsp (:translate %multiply-high)
|
||||
(define-source-transform %multiply-high (x y)
|
||||
`(values (sb-bignum:%multiply ,x ,y)))
|
||||
)
|
||||
|
|
@ -3293,12 +3285,12 @@
|
|||
((same-leaf-ref-p x y) t)
|
||||
((not (types-equal-or-intersect (lvar-type x) (lvar-type y)))
|
||||
nil)
|
||||
#+(vop-translates sb-kernel:%instance-ref-eq)
|
||||
;; Reduce (eq (%instance-ref x i) Y) to 1 instruction
|
||||
;; if possible, but do not defer the memory load unless doing
|
||||
;; so can have no effect, i.e. Y is a constant or provably not
|
||||
;; effectful. For now, just handle constant Y.
|
||||
((and (constant-lvar-p y)
|
||||
((and (vop-existsp :translate %instance-ref-eq)
|
||||
(constant-lvar-p y)
|
||||
(combination-p use)
|
||||
(almost-immediately-used-p x use)
|
||||
(eql '%instance-ref (lvar-fun-name (combination-fun use)))
|
||||
|
|
@ -3610,11 +3602,11 @@
|
|||
(csubtypep y-type (specifier-type 'float)))
|
||||
(and (csubtypep x-type (specifier-type '(complex float)))
|
||||
(csubtypep y-type (specifier-type '(complex float))))
|
||||
#+(vop-named sb-vm::=/complex-single-float)
|
||||
(and (csubtypep x-type (specifier-type '(or single-float (complex single-float))))
|
||||
(and (vop-existsp :named sb-vm::=/complex-single-float)
|
||||
(csubtypep x-type (specifier-type '(or single-float (complex single-float))))
|
||||
(csubtypep y-type (specifier-type '(or single-float (complex single-float)))))
|
||||
#+(vop-named sb-vm::=/complex-double-float)
|
||||
(and (csubtypep x-type (specifier-type '(or double-float (complex double-float))))
|
||||
(and (vop-existsp :named sb-vm::=/complex-double-float)
|
||||
(csubtypep x-type (specifier-type '(or double-float (complex double-float))))
|
||||
(csubtypep y-type (specifier-type '(or double-float (complex double-float))))))
|
||||
;; They are both floats. Leave as = so that -0.0 is
|
||||
;; handled correctly.
|
||||
|
|
|
|||
|
|
@ -109,8 +109,8 @@
|
|||
;; If it's a lisp-rep-type, the CTYPE should be one already.
|
||||
(aver (not (compute-lisp-rep-type alien-type)))
|
||||
`(sb-alien::alien-value-typep object ',alien-type)))
|
||||
#+(vop-translates sb-int:fixnump-instance-ref)
|
||||
((and (type= type (specifier-type 'fixnum))
|
||||
((and (vop-existsp :translate fixnump-instance-ref)
|
||||
(type= type (specifier-type 'fixnum))
|
||||
(let ((use (lvar-uses object)))
|
||||
(and (combination-p use)
|
||||
(almost-immediately-used-p object use)
|
||||
|
|
@ -876,8 +876,9 @@
|
|||
;; - implement half-width structure slots
|
||||
;; Since both of those are not happening any time soon, ...
|
||||
(deeper-p
|
||||
#+(vop-translates sb-c::layout-depthoid-gt) `(layout-depthoid-gt ,n-layout ,depthoid)
|
||||
#-(vop-translates sb-c::layout-depthoid-gt) `(> (layout-depthoid ,n-layout) ,depthoid))
|
||||
(if (vop-existsp :translate layout-depthoid-gt)
|
||||
`(layout-depthoid-gt ,n-layout ,depthoid)
|
||||
`(> (layout-depthoid ,n-layout) ,depthoid)))
|
||||
(nth-ancestor ; This is possibly unused (if no compile-time layout, or depthoid -1)
|
||||
;; Use DATA-VECTOR-REF directly, since that's what SVREF in SAFETY 0 will become.
|
||||
`(locally (declare (optimize (safety 0)))
|
||||
|
|
@ -926,8 +927,8 @@
|
|||
`(let ((object-layout ,layout-getter))
|
||||
(or (eq object-layout ',layout)
|
||||
(eq object-layout ',other-layout))))
|
||||
#+(vop-named sb-vm::layout-eq)
|
||||
((equal layout-getter '(%instance-layout object))
|
||||
((and (vop-existsp :named sb-vm::layout-eq)
|
||||
(equal layout-getter '(%instance-layout object)))
|
||||
`(sb-vm::layout-eq object ',layout))
|
||||
(t
|
||||
`(eq ,layout-getter ',layout)))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue