(:node-var node)
(:generator 0
(cond ((zerop num)
- ;; (move result nil-value)
- (inst mov result nil-value))
- ((and star (= num 1))
- (move result (tn-ref-tn things)))
- (t
- (macrolet
- ((store-car (tn list &optional (slot cons-car-slot))
- `(let ((reg
- (sc-case ,tn
- ((any-reg descriptor-reg) ,tn)
- ((control-stack)
- (move temp ,tn)
- temp))))
- (storew reg ,list ,slot list-pointer-lowtag))))
- (let ((cons-cells (if star (1- num) num)))
- (pseudo-atomic
- (allocation res (* (pad-data-block cons-size) cons-cells) node
- (awhen (sb!c::node-lvar node)
- (sb!c::lvar-dynamic-extent it)))
- (inst lea res
- (make-ea :byte :base res :disp list-pointer-lowtag))
- (move ptr res)
- (dotimes (i (1- cons-cells))
- (store-car (tn-ref-tn things) ptr)
- (setf things (tn-ref-across things))
- (inst add ptr (pad-data-block cons-size))
- (storew ptr ptr (- cons-cdr-slot cons-size)
- list-pointer-lowtag))
- (store-car (tn-ref-tn things) ptr)
- (cond (star
- (setf things (tn-ref-across things))
- (store-car (tn-ref-tn things) ptr cons-cdr-slot))
- (t
- (storew nil-value ptr cons-cdr-slot
- list-pointer-lowtag)))
- (aver (null (tn-ref-across things)))))
- (move result res))))))
+ ;; (move result nil-value)
+ (inst mov result nil-value))
+ ((and star (= num 1))
+ (move result (tn-ref-tn things)))
+ (t
+ (macrolet
+ ((store-car (tn list &optional (slot cons-car-slot))
+ `(let ((reg
+ (sc-case ,tn
+ ((any-reg descriptor-reg) ,tn)
+ ((control-stack)
+ (move temp ,tn)
+ temp))))
+ (storew reg ,list ,slot list-pointer-lowtag))))
+ (let ((cons-cells (if star (1- num) num)))
+ (pseudo-atomic
+ (allocation res (* (pad-data-block cons-size) cons-cells) node
+ (awhen (sb!c::node-lvar node)
+ (sb!c::lvar-dynamic-extent it)))
+ (inst lea res
+ (make-ea :byte :base res :disp list-pointer-lowtag))
+ (move ptr res)
+ (dotimes (i (1- cons-cells))
+ (store-car (tn-ref-tn things) ptr)
+ (setf things (tn-ref-across things))
+ (inst add ptr (pad-data-block cons-size))
+ (storew ptr ptr (- cons-cdr-slot cons-size)
+ list-pointer-lowtag))
+ (store-car (tn-ref-tn things) ptr)
+ (cond (star
+ (setf things (tn-ref-across things))
+ (store-car (tn-ref-tn things) ptr cons-cdr-slot))
+ (t
+ (storew nil-value ptr cons-cdr-slot
+ list-pointer-lowtag)))
+ (aver (null (tn-ref-across things)))))
+ (move result res))))))
(define-vop (list list-or-list*)
(:variant nil))
(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg) :target boxed)
- (unboxed-arg :scs (any-reg) :target unboxed))
+ (unboxed-arg :scs (any-reg) :target unboxed))
(:results (result :scs (descriptor-reg) :from :eval))
(:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
(:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
(storew name result fdefn-name-slot other-pointer-lowtag)
(storew nil-value result fdefn-fun-slot other-pointer-lowtag)
(storew (make-fixup "undefined_tramp" :foreign)
- result fdefn-raw-addr-slot other-pointer-lowtag))))
+ result fdefn-raw-addr-slot other-pointer-lowtag))))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(let ((size (+ length closure-info-offset)))
(allocation result (pad-data-block size) node stack-allocate-p)
(inst lea result
- (make-ea :byte :base result :disp fun-pointer-lowtag))
+ (make-ea :byte :base result :disp fun-pointer-lowtag))
(storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
- result 0 fun-pointer-lowtag))
+ result 0 fun-pointer-lowtag))
(loadw temp function closure-fun-slot fun-pointer-lowtag)
(storew temp result closure-fun-slot fun-pointer-lowtag))))
(:node-var node)
(:generator 10
(with-fixed-allocation
- (result value-cell-header-widetag value-cell-size node)
+ (result value-cell-header-widetag value-cell-size node)
(storew value result value-cell-value-slot other-pointer-lowtag))))
\f
;;;; automatic allocators for primitive objects
(inst lea result (make-ea :byte :base result :disp lowtag))
(when type
(storew (logior (ash (1- words) n-widetag-bits) type)
- result
- 0
- lowtag)))))
+ result
+ 0
+ lowtag)))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
(:node-var node)
(:generator 50
(inst lea bytes
- (make-ea :qword :base extra :disp (* (1+ words) n-word-bytes)))
+ (make-ea :qword :base extra :disp (* (1+ words) n-word-bytes)))
(inst mov header bytes)
(inst shl header (- n-widetag-bits 3)) ; w+1 to length field
- (inst lea header ; (w-1 << 8) | type
- (make-ea :qword :base header :disp (+ (ash -2 n-widetag-bits) type)))
+ (inst lea header ; (w-1 << 8) | type
+ (make-ea :qword :base header :disp (+ (ash -2 n-widetag-bits) type)))
(inst and bytes (lognot lowtag-mask))
(pseudo-atomic
(allocation result bytes node)
(with-fixed-allocation (result symbol-header-widetag symbol-size node)
(storew name result symbol-name-slot other-pointer-lowtag)
(storew unbound-marker-widetag
- result
- symbol-value-slot
- other-pointer-lowtag)
+ result
+ symbol-value-slot
+ other-pointer-lowtag)
;; Set up a random hash value for the symbol. Perhaps the object
;; address could be used for even faster and smaller code!
;; FIXME: We don't mind the symbol hash not being repeatable, so
;; we might as well add in the object address here, too. (Adding entropy
;; is good, even if ANSI doesn't understand that.)
(inst imul temp
- (make-fixup "fast_random_state" :foreign)
- 1103515245)
+ (make-fixup "fast_random_state" :foreign)
+ 1103515245)
(inst add temp 12345)
(inst mov (make-fixup "fast_random_state" :foreign)
- temp)
+ temp)
;; We want a positive fixnum for the hash value, so discard the LS bits.
;;
;; FIXME: OK, who wants to tell me (CSR) why these two
(define-vop (fast-fixnum-binop fast-safe-arith-op)
(:args (x :target r :scs (any-reg)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg)
- (sc-is r control-stack)
- (location= x r))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r))))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg) :from (:argument 0)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg)
- (sc-is r control-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r)))))
(:result-types tagged-num)
(:note "inline fixnum arithmetic"))
(define-vop (fast-unsigned-binop fast-safe-arith-op)
(:args (x :target r :scs (unsigned-reg)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r))))
- (y :scs (unsigned-reg unsigned-stack)))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg) :from (:argument 0)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 64) arithmetic"))
(define-vop (fast-signed-binop fast-safe-arith-op)
(:args (x :target r :scs (signed-reg)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg)
- (sc-is r signed-stack)
- (location= x r))))
- (y :scs (signed-reg signed-stack)))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (sc-is r signed-stack)
+ (location= x r))))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg) :from (:argument 0)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg)
- (sc-is r signed-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (sc-is r signed-stack)
+ (location= x r)))))
(:result-types signed-num)
(:note "inline (signed-byte 64) arithmetic"))
(:info y)
(:arg-types tagged-num (:constant (signed-byte 29)))
(:results (r :scs (any-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types tagged-num)
(:note "inline fixnum arithmetic"))
(:info y)
(:arg-types unsigned-num (:constant (unsigned-byte 31)))
(:results (r :scs (unsigned-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 64) arithmetic"))
(:info y)
(:arg-types signed-num (:constant (signed-byte 32)))
(:results (r :scs (signed-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types signed-num)
(:note "inline (signed-byte 64) arithmetic"))
(macrolet ((define-binop (translate untagged-penalty op)
- `(progn
- (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
- fast-fixnum-binop)
- (:translate ,translate)
- (:generator 2
- (move r x)
- (inst ,op r y)))
- (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
- fast-fixnum-binop-c)
- (:translate ,translate)
- (:generator 1
- (move r x)
- (inst ,op r (fixnumize y))))
- (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
- fast-signed-binop)
- (:translate ,translate)
- (:generator ,(1+ untagged-penalty)
- (move r x)
- (inst ,op r y)))
- (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
- fast-signed-binop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (move r x)
- (inst ,op r y)))
- (define-vop (,(symbolicate "FAST-"
- translate
- "/UNSIGNED=>UNSIGNED")
- fast-unsigned-binop)
- (:translate ,translate)
- (:generator ,(1+ untagged-penalty)
- (move r x)
- (inst ,op r y)))
- (define-vop (,(symbolicate 'fast-
- translate
- '-c/unsigned=>unsigned)
- fast-unsigned-binop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (move r x)
- (inst ,op r y))))))
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+ fast-fixnum-binop)
+ (:translate ,translate)
+ (:generator 2
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+ fast-fixnum-binop-c)
+ (:translate ,translate)
+ (:generator 1
+ (move r x)
+ (inst ,op r (fixnumize y))))
+ (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+ fast-signed-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+ fast-signed-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate "FAST-"
+ translate
+ "/UNSIGNED=>UNSIGNED")
+ fast-unsigned-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate 'fast-
+ translate
+ '-c/unsigned=>unsigned)
+ fast-unsigned-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (move r x)
+ (inst ,op r y))))))
;;(define-binop + 4 add)
(define-binop - 4 sub)
(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
(:translate +)
(:args (x :scs (any-reg) :target r
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg)
- (sc-is r control-stack)
- (location= x r))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r))))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg) :from (:argument 0)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg)
- (sc-is r control-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r)))))
(:result-types tagged-num)
(:note "inline fixnum arithmetic")
(:generator 2
(cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
- (not (location= x r)))
- (inst lea r (make-ea :qword :base x :index y :scale 1)))
- (t
- (move r x)
- (inst add r y)))))
+ (not (location= x r)))
+ (inst lea r (make-ea :qword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r y)))))
(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
(:translate +)
(:info y)
(:arg-types tagged-num (:constant (signed-byte 29)))
(:results (r :scs (any-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types tagged-num)
(:note "inline fixnum arithmetic")
(:generator 1
(cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)))
- (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
- (t
- (move r x)
- (inst add r (fixnumize y))))))
+ (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
+ (t
+ (move r x)
+ (inst add r (fixnumize y))))))
(define-vop (fast-+/signed=>signed fast-safe-arith-op)
(:translate +)
(:args (x :scs (signed-reg) :target r
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg)
- (sc-is r signed-stack)
- (location= x r))))
- (y :scs (signed-reg signed-stack)))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (sc-is r signed-stack)
+ (location= x r))))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg) :from (:argument 0)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg)
- (location= x r)))))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (location= x r)))))
(:result-types signed-num)
(:note "inline (signed-byte 64) arithmetic")
(:generator 5
(cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
- (not (location= x r)))
- (inst lea r (make-ea :qword :base x :index y :scale 1)))
- (t
- (move r x)
- (inst add r y)))))
+ (not (location= x r)))
+ (inst lea r (make-ea :qword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r y)))))
;;;; Special logand cases: (logand signed unsigned) => unsigned
(define-vop (fast-logand/signed-unsigned=>unsigned
- fast-logand/unsigned=>unsigned)
+ fast-logand/unsigned=>unsigned)
(:args (x :target r :scs (signed-reg)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r))))
- (y :scs (unsigned-reg unsigned-stack)))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types signed-num unsigned-num))
(define-vop (fast-logand-c/signed-unsigned=>unsigned
- fast-logand-c/unsigned=>unsigned)
+ fast-logand-c/unsigned=>unsigned)
(:args (x :target r :scs (signed-reg signed-stack)))
(:arg-types signed-num (:constant (unsigned-byte 31))))
(define-vop (fast-logand/unsigned-signed=>unsigned
- fast-logand/unsigned=>unsigned)
+ fast-logand/unsigned=>unsigned)
(:args (x :target r :scs (unsigned-reg)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y signed-reg)
- (sc-is r unsigned-stack)
- (location= x r))))
- (y :scs (signed-reg signed-stack)))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y signed-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (signed-reg signed-stack)))
(:arg-types unsigned-num signed-num))
\f
(:info y)
(:arg-types signed-num (:constant (signed-byte 32)))
(:results (r :scs (signed-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types signed-num)
(:note "inline (signed-byte 64) arithmetic")
(:generator 4
(cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
- (not (location= x r)))
- (inst lea r (make-ea :qword :base x :disp y)))
- (t
- (move r x)
- (if (= y 1)
- (inst inc r)
- (inst add r y))))))
+ (not (location= x r)))
+ (inst lea r (make-ea :qword :base x :disp y)))
+ (t
+ (move r x)
+ (if (= y 1)
+ (inst inc r)
+ (inst add r y))))))
(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
(:translate +)
(:args (x :scs (unsigned-reg) :target r
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r))))
- (y :scs (unsigned-reg unsigned-stack)))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg) :from (:argument 0)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 64) arithmetic")
(:generator 5
(cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
- (sc-is r unsigned-reg) (not (location= x r)))
- (inst lea r (make-ea :qword :base x :index y :scale 1)))
- (t
- (move r x)
- (inst add r y)))))
+ (sc-is r unsigned-reg) (not (location= x r)))
+ (inst lea r (make-ea :qword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r y)))))
(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
(:translate +)
(:info y)
(:arg-types unsigned-num (:constant (unsigned-byte 31)))
(:results (r :scs (unsigned-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 64) arithmetic")
(:generator 4
(cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
- (not (location= x r)))
- (inst lea r (make-ea :qword :base x :disp y)))
- (t
- (move r x)
- (if (= y 1)
- (inst inc r)
- (inst add r y))))))
+ (not (location= x r)))
+ (inst lea r (make-ea :qword :base x :disp y)))
+ (t
+ (move r x)
+ (if (= y 1)
+ (inst inc r)
+ (inst add r y))))))
\f
;;;; multiplication and division
(:translate *)
;; We need different loading characteristics.
(:args (x :scs (any-reg) :target r)
- (y :scs (any-reg control-stack)))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg) :from (:argument 0)))
(:result-types tagged-num)
;; We need different loading characteristics.
(:args (x :scs (any-reg control-stack)))
(:info y)
- (:arg-types tagged-num (:constant (signed-byte 29)))
+ (:arg-types tagged-num (:constant (signed-byte 29)))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:note "inline fixnum arithmetic")
(:translate *)
;; We need different loading characteristics.
(:args (x :scs (signed-reg) :target r)
- (y :scs (signed-reg signed-stack)))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg) :from (:argument 0)))
(:result-types signed-num)
(define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
(:translate *)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg unsigned-stack)))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 0) :to :result) eax)
+ :from (:argument 0) :to :result) eax)
(:temporary (:sc unsigned-reg :offset edx-offset
- :from :eval :to :result) edx)
+ :from :eval :to :result) edx)
(:ignore edx)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (any-reg) :target eax)
- (y :scs (any-reg control-stack)))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:temporary (:sc signed-reg :offset eax-offset :target quo
- :from (:argument 0) :to (:result 0)) eax)
+ :from (:argument 0) :to (:result 0)) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :target rem
- :from (:argument 0) :to (:result 1)) edx)
+ :from (:argument 0) :to (:result 1)) edx)
(:results (quo :scs (any-reg))
- (rem :scs (any-reg)))
+ (rem :scs (any-reg)))
(:result-types tagged-num tagged-num)
(:note "inline fixnum arithmetic")
(:vop-var vop)
(:generator 31
(let ((zero (generate-error-code vop division-by-zero-error x y)))
(if (sc-is y any-reg)
- (inst test y y) ; smaller instruction
- (inst cmp y 0))
+ (inst test y y) ; smaller instruction
+ (inst cmp y 0))
(inst jmp :eq zero))
(move eax x)
(inst cqo)
(inst idiv eax y)
(if (location= quo eax)
- (inst shl eax 3)
- (inst lea quo (make-ea :qword :index eax :scale 8)))
+ (inst shl eax 3)
+ (inst lea quo (make-ea :qword :index eax :scale 8)))
(move rem edx)))
(define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
(:info y)
(:arg-types tagged-num (:constant (signed-byte 29)))
(:temporary (:sc signed-reg :offset eax-offset :target quo
- :from :argument :to (:result 0)) eax)
+ :from :argument :to (:result 0)) eax)
(:temporary (:sc any-reg :offset edx-offset :target rem
- :from :eval :to (:result 1)) edx)
+ :from :eval :to (:result 1)) edx)
(:temporary (:sc any-reg :from :eval :to :result) y-arg)
(:results (quo :scs (any-reg))
- (rem :scs (any-reg)))
+ (rem :scs (any-reg)))
(:result-types tagged-num tagged-num)
(:note "inline fixnum arithmetic")
(:vop-var vop)
(inst mov y-arg (fixnumize y))
(inst idiv eax y-arg)
(if (location= quo eax)
- (inst shl eax 3)
- (inst lea quo (make-ea :qword :index eax :scale 8)))
+ (inst shl eax 3)
+ (inst lea quo (make-ea :qword :index eax :scale 8)))
(move rem edx)))
(define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg signed-stack)))
+ (y :scs (unsigned-reg signed-stack)))
(:arg-types unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :target quo
- :from (:argument 0) :to (:result 0)) eax)
+ :from (:argument 0) :to (:result 0)) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :target rem
- :from (:argument 0) :to (:result 1)) edx)
+ :from (:argument 0) :to (:result 1)) edx)
(:results (quo :scs (unsigned-reg))
- (rem :scs (unsigned-reg)))
+ (rem :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 64) arithmetic")
(:vop-var vop)
(:generator 33
(let ((zero (generate-error-code vop division-by-zero-error x y)))
(if (sc-is y unsigned-reg)
- (inst test y y) ; smaller instruction
- (inst cmp y 0))
+ (inst test y y) ; smaller instruction
+ (inst cmp y 0))
(inst jmp :eq zero))
(move eax x)
(inst xor edx edx)
(:info y)
(:arg-types unsigned-num (:constant (unsigned-byte 31)))
(:temporary (:sc unsigned-reg :offset eax-offset :target quo
- :from :argument :to (:result 0)) eax)
+ :from :argument :to (:result 0)) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :target rem
- :from :eval :to (:result 1)) edx)
+ :from :eval :to (:result 1)) edx)
(:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
(:results (quo :scs (unsigned-reg))
- (rem :scs (unsigned-reg)))
+ (rem :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 64) arithmetic")
(:vop-var vop)
(define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (signed-reg) :target eax)
- (y :scs (signed-reg signed-stack)))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:temporary (:sc signed-reg :offset eax-offset :target quo
- :from (:argument 0) :to (:result 0)) eax)
+ :from (:argument 0) :to (:result 0)) eax)
(:temporary (:sc signed-reg :offset edx-offset :target rem
- :from (:argument 0) :to (:result 1)) edx)
+ :from (:argument 0) :to (:result 1)) edx)
(:results (quo :scs (signed-reg))
- (rem :scs (signed-reg)))
+ (rem :scs (signed-reg)))
(:result-types signed-num signed-num)
(:note "inline (signed-byte 64) arithmetic")
(:vop-var vop)
(:generator 33
(let ((zero (generate-error-code vop division-by-zero-error x y)))
(if (sc-is y signed-reg)
- (inst test y y) ; smaller instruction
- (inst cmp y 0))
+ (inst test y y) ; smaller instruction
+ (inst cmp y 0))
(inst jmp :eq zero))
(move eax x)
(inst cqo)
(:info y)
(:arg-types signed-num (:constant (signed-byte 32)))
(:temporary (:sc signed-reg :offset eax-offset :target quo
- :from :argument :to (:result 0)) eax)
+ :from :argument :to (:result 0)) eax)
(:temporary (:sc signed-reg :offset edx-offset :target rem
- :from :eval :to (:result 1)) edx)
+ :from :eval :to (:result 1)) edx)
(:temporary (:sc signed-reg :from :eval :to :result) y-arg)
(:results (quo :scs (signed-reg))
- (rem :scs (signed-reg)))
+ (rem :scs (signed-reg)))
(:result-types signed-num signed-num)
(:note "inline (signed-byte 64) arithmetic")
(:vop-var vop)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (any-reg) :target result
- :load-if (not (and (sc-is number any-reg control-stack)
- (sc-is result any-reg control-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number any-reg control-stack)
+ (sc-is result any-reg control-stack)
+ (location= number result)))))
(:info amount)
(:arg-types tagged-num (:constant integer))
(:results (result :scs (any-reg)
- :load-if (not (and (sc-is number control-stack)
- (sc-is result control-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number control-stack)
+ (sc-is result control-stack)
+ (location= number result)))))
(:result-types tagged-num)
(:note "inline ASH")
(:generator 2
(cond ((and (= amount 1) (not (location= number result)))
- (inst lea result (make-ea :qword :index number :scale 2)))
- ((and (= amount 2) (not (location= number result)))
- (inst lea result (make-ea :qword :index number :scale 4)))
- ((and (= amount 3) (not (location= number result)))
- (inst lea result (make-ea :qword :index number :scale 8)))
- (t
- (move result number)
+ (inst lea result (make-ea :qword :index number :scale 2)))
+ ((and (= amount 2) (not (location= number result)))
+ (inst lea result (make-ea :qword :index number :scale 4)))
+ ((and (= amount 3) (not (location= number result)))
+ (inst lea result (make-ea :qword :index number :scale 8)))
+ (t
+ (move result number)
(cond ((plusp amount)
;; We don't have to worry about overflow because of the
;; result type restriction.
(inst shl result amount))
- (t
+ (t
;; Since the shift instructions take the shift amount
;; modulo 64 we must special case amounts of 64 and more.
;; Because fixnums have only 61 bits, the result is 0 or
(define-vop (fast-ash-left/fixnum=>fixnum)
(:translate ash)
(:args (number :scs (any-reg) :target result
- :load-if (not (and (sc-is number control-stack)
- (sc-is result control-stack)
- (location= number result))))
- (amount :scs (unsigned-reg) :target ecx))
+ :load-if (not (and (sc-is number control-stack)
+ (sc-is result control-stack)
+ (location= number result))))
+ (amount :scs (unsigned-reg) :target ecx))
(:arg-types tagged-num positive-fixnum)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (result :scs (any-reg) :from (:argument 0)
- :load-if (not (and (sc-is number control-stack)
- (sc-is result control-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number control-stack)
+ (sc-is result control-stack)
+ (location= number result)))))
(:result-types tagged-num)
(:policy :fast-safe)
(:note "inline ASH")
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (signed-reg) :target result
- :load-if (not (and (sc-is number signed-stack)
- (sc-is result signed-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number signed-stack)
+ (sc-is result signed-stack)
+ (location= number result)))))
(:info amount)
(:arg-types signed-num (:constant integer))
(:results (result :scs (signed-reg)
- :load-if (not (and (sc-is number signed-stack)
- (sc-is result signed-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number signed-stack)
+ (sc-is result signed-stack)
+ (location= number result)))))
(:result-types signed-num)
(:note "inline ASH")
(:generator 3
(cond ((and (= amount 1) (not (location= number result)))
- (inst lea result (make-ea :qword :index number :scale 2)))
- ((and (= amount 2) (not (location= number result)))
- (inst lea result (make-ea :qword :index number :scale 4)))
- ((and (= amount 3) (not (location= number result)))
- (inst lea result (make-ea :qword :index number :scale 8)))
- (t
- (move result number)
- (cond ((plusp amount) (inst shl result amount))
- (t (inst sar result (min 63 (- amount)))))))))
+ (inst lea result (make-ea :qword :index number :scale 2)))
+ ((and (= amount 2) (not (location= number result)))
+ (inst lea result (make-ea :qword :index number :scale 4)))
+ ((and (= amount 3) (not (location= number result)))
+ (inst lea result (make-ea :qword :index number :scale 8)))
+ (t
+ (move result number)
+ (cond ((plusp amount) (inst shl result amount))
+ (t (inst sar result (min 63 (- amount)))))))))
(define-vop (fast-ash-c/unsigned=>unsigned)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (unsigned-reg) :target result
- :load-if (not (and (sc-is number unsigned-stack)
- (sc-is result unsigned-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number unsigned-stack)
+ (sc-is result unsigned-stack)
+ (location= number result)))))
(:info amount)
(:arg-types unsigned-num (:constant integer))
(:results (result :scs (unsigned-reg)
- :load-if (not (and (sc-is number unsigned-stack)
- (sc-is result unsigned-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number unsigned-stack)
+ (sc-is result unsigned-stack)
+ (location= number result)))))
(:result-types unsigned-num)
(:note "inline ASH")
(:generator 3
(cond ((and (= amount 1) (not (location= number result)))
- (inst lea result (make-ea :qword :index number :scale 2)))
- ((and (= amount 2) (not (location= number result)))
- (inst lea result (make-ea :qword :index number :scale 4)))
- ((and (= amount 3) (not (location= number result)))
- (inst lea result (make-ea :qword :index number :scale 8)))
- (t
- (move result number)
- (cond ((< -64 amount 64) ;; XXXX
+ (inst lea result (make-ea :qword :index number :scale 2)))
+ ((and (= amount 2) (not (location= number result)))
+ (inst lea result (make-ea :qword :index number :scale 4)))
+ ((and (= amount 3) (not (location= number result)))
+ (inst lea result (make-ea :qword :index number :scale 8)))
+ (t
+ (move result number)
+ (cond ((< -64 amount 64) ;; XXXX
;; this code is used both in ASH and ASH-MOD32, so
;; be careful
(if (plusp amount)
(inst shl result amount)
(inst shr result (- amount))))
- (t (if (sc-is result unsigned-reg)
+ (t (if (sc-is result unsigned-reg)
(inst xor result result)
(inst mov result 0))))))))
(define-vop (fast-ash-left/signed=>signed)
(:translate ash)
(:args (number :scs (signed-reg) :target result
- :load-if (not (and (sc-is number signed-stack)
- (sc-is result signed-stack)
- (location= number result))))
- (amount :scs (unsigned-reg) :target ecx))
+ :load-if (not (and (sc-is number signed-stack)
+ (sc-is result signed-stack)
+ (location= number result))))
+ (amount :scs (unsigned-reg) :target ecx))
(:arg-types signed-num positive-fixnum)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (result :scs (signed-reg) :from (:argument 0)
- :load-if (not (and (sc-is number signed-stack)
- (sc-is result signed-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number signed-stack)
+ (sc-is result signed-stack)
+ (location= number result)))))
(:result-types signed-num)
(:policy :fast-safe)
(:note "inline ASH")
(define-vop (fast-ash-left/unsigned=>unsigned)
(:translate ash)
(:args (number :scs (unsigned-reg) :target result
- :load-if (not (and (sc-is number unsigned-stack)
- (sc-is result unsigned-stack)
- (location= number result))))
- (amount :scs (unsigned-reg) :target ecx))
+ :load-if (not (and (sc-is number unsigned-stack)
+ (sc-is result unsigned-stack)
+ (location= number result))))
+ (amount :scs (unsigned-reg) :target ecx))
(:arg-types unsigned-num positive-fixnum)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (result :scs (unsigned-reg) :from (:argument 0)
- :load-if (not (and (sc-is number unsigned-stack)
- (sc-is result unsigned-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number unsigned-stack)
+ (sc-is result unsigned-stack)
+ (location= number result)))))
(:result-types unsigned-num)
(:policy :fast-safe)
(:note "inline ASH")
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (signed-reg) :target result)
- (amount :scs (signed-reg) :target ecx))
+ (amount :scs (signed-reg) :target ecx))
(:arg-types signed-num signed-num)
(:results (result :scs (signed-reg) :from (:argument 0)))
(:result-types signed-num)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (unsigned-reg) :target result)
- (amount :scs (signed-reg) :target ecx))
+ (amount :scs (signed-reg) :target ecx))
(:arg-types unsigned-num signed-num)
(:results (result :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num)
(defoptimizer (%lea derive-type) ((base index scale disp))
(when (and (constant-lvar-p scale)
- (constant-lvar-p disp))
+ (constant-lvar-p disp))
(let ((scale (lvar-value scale))
- (disp (lvar-value disp))
- (base-type (lvar-type base))
- (index-type (lvar-type index)))
+ (disp (lvar-value disp))
+ (base-type (lvar-type base))
+ (index-type (lvar-type index)))
(when (and (numeric-type-p base-type)
- (numeric-type-p index-type))
- (let ((base-lo (numeric-type-low base-type))
- (base-hi (numeric-type-high base-type))
- (index-lo (numeric-type-low index-type))
- (index-hi (numeric-type-high index-type)))
- (make-numeric-type :class 'integer
- :complexp :real
- :low (when (and base-lo index-lo)
- (+ base-lo (* index-lo scale) disp))
- :high (when (and base-hi index-hi)
- (+ base-hi (* index-hi scale) disp))))))))
+ (numeric-type-p index-type))
+ (let ((base-lo (numeric-type-low base-type))
+ (base-hi (numeric-type-high base-type))
+ (index-lo (numeric-type-low index-type))
+ (index-hi (numeric-type-high index-type)))
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :low (when (and base-lo index-lo)
+ (+ base-lo (* index-lo scale) disp))
+ :high (when (and base-hi index-hi)
+ (+ base-hi (* index-hi scale) disp))))))))
(defun %lea (base index scale disp)
(+ base (* index scale) disp))
(:translate %lea)
(:policy :fast-safe)
(:args (base :scs (unsigned-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:info scale disp)
(:arg-types unsigned-num unsigned-num
- (:constant (member 1 2 4 8))
- (:constant (signed-byte 64)))
+ (:constant (member 1 2 4 8))
+ (:constant (signed-byte 64)))
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 5
(inst lea r (make-ea :qword :base base :index index
- :scale scale :disp disp))))
+ :scale scale :disp disp))))
(define-vop (%lea/signed=>signed)
(:translate %lea)
(:policy :fast-safe)
(:args (base :scs (signed-reg))
- (index :scs (signed-reg)))
+ (index :scs (signed-reg)))
(:info scale disp)
(:arg-types signed-num signed-num
- (:constant (member 1 2 4 8))
- (:constant (signed-byte 64)))
+ (:constant (member 1 2 4 8))
+ (:constant (signed-byte 64)))
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:generator 4
(inst lea r (make-ea :qword :base base :index index
- :scale scale :disp disp))))
+ :scale scale :disp disp))))
(define-vop (%lea/fixnum=>fixnum)
(:translate %lea)
(:policy :fast-safe)
(:args (base :scs (any-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:info scale disp)
(:arg-types tagged-num tagged-num
- (:constant (member 1 2 4 8))
- (:constant (signed-byte 64)))
+ (:constant (member 1 2 4 8))
+ (:constant (signed-byte 64)))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:generator 3
(inst lea r (make-ea :qword :base base :index index
- :scale scale :disp disp))))
+ :scale scale :disp disp))))
;;; FIXME: before making knowledge of this too public, it needs to be
;;; fixed so that it's actually _faster_ than the non-CMOV version; at
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (unsigned-reg) :target result)
- (amount :scs (signed-reg) :target ecx))
+ (amount :scs (signed-reg) :target ecx))
(:arg-types unsigned-num signed-num)
(:results (result :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num)
(inst cmp ecx 63)
(inst cmov :nbe result zero)
(inst jmp DONE)
-
+
POSITIVE
;; The result-type ensures us that this shift will not overflow.
(inst shl result :cl)
(move result arg)
(move t1 arg)
- (inst mov temp result)
+ (inst mov temp result)
(inst shr temp 1)
- (inst and result #x55555555) ; note these masks will restrict the
- (inst and temp #x55555555) ; count to the lower half of arg
+ (inst and result #x55555555) ; note these masks will restrict the
+ (inst and temp #x55555555) ; count to the lower half of arg
(inst add result temp)
(inst mov temp result)
;;; now do the upper half
(inst shr t1 32)
- (inst mov temp t1)
+ (inst mov temp t1)
(inst shr temp 1)
- (inst and t1 #x55555555)
+ (inst and t1 #x55555555)
(inst and temp #x55555555)
(inst add t1 temp)
(define-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg))))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison"))
(define-vop (fast-conditional/signed fast-conditional)
(:args (x :scs (signed-reg)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg))))
- (y :scs (signed-reg signed-stack)))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg))))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:note "inline (signed-byte 64) comparison"))
(define-vop (fast-conditional/unsigned fast-conditional)
(:args (x :scs (unsigned-reg)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg))))
- (y :scs (unsigned-reg unsigned-stack)))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg))))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 64) comparison"))
(:info target not-p y))
(macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
- `(progn
- ,@(mapcar
- (lambda (suffix cost signed)
- `(define-vop (;; FIXME: These could be done more
- ;; cleanly with SYMBOLICATE.
- ,(intern (format nil "~:@(FAST-IF-~A~A~)"
- tran suffix))
- ,(intern
- (format nil "~:@(FAST-CONDITIONAL~A~)"
- suffix)))
- (:translate ,tran)
- (:generator ,cost
- (inst cmp x
- ,(if (eq suffix '-c/fixnum)
- '(fixnumize y)
- 'y))
- (inst jmp (if not-p
- ,(if signed
- not-cond
- not-unsigned)
- ,(if signed
- cond
- unsigned))
- target))))
- '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
-; '(/fixnum /signed /unsigned)
- '(4 3 6 5 6 5)
- '(t t t t nil nil)))))
+ `(progn
+ ,@(mapcar
+ (lambda (suffix cost signed)
+ `(define-vop (;; FIXME: These could be done more
+ ;; cleanly with SYMBOLICATE.
+ ,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ tran suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,tran)
+ (:generator ,cost
+ (inst cmp x
+ ,(if (eq suffix '-c/fixnum)
+ '(fixnumize y)
+ 'y))
+ (inst jmp (if not-p
+ ,(if signed
+ not-cond
+ not-unsigned)
+ ,(if signed
+ cond
+ unsigned))
+ target))))
+ '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+; '(/fixnum /signed /unsigned)
+ '(4 3 6 5 6 5)
+ '(t t t t nil nil)))))
(define-conditional-vop < :l :b :ge :ae)
(define-conditional-vop > :g :a :le :be))
(:translate eql)
(:generator 5
(cond ((and (sc-is x signed-reg) (zerop y))
- (inst test x x)) ; smaller instruction
- (t
- (inst cmp x y)))
+ (inst test x x)) ; smaller instruction
+ (t
+ (inst cmp x y)))
(inst jmp (if not-p :ne :e) target)))
(define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
(:translate eql)
(:generator 5
(cond ((and (sc-is x unsigned-reg) (zerop y))
- (inst test x x)) ; smaller instruction
- (t
- (inst cmp x y)))
+ (inst test x x)) ; smaller instruction
+ (t
+ (inst cmp x y)))
(inst jmp (if not-p :ne :e) target)))
;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
(define-vop (fast-eql/fixnum fast-conditional)
(:args (x :scs (any-reg)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg))))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison")
(:translate eql)
(inst jmp (if not-p :ne :e) target)))
(define-vop (generic-eql/fixnum fast-eql/fixnum)
(:args (x :scs (any-reg descriptor-reg)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg))))
+ (y :scs (any-reg control-stack)))
(:arg-types * tagged-num)
(:variant-cost 7))
(:translate eql)
(:generator 2
(cond ((and (sc-is x any-reg) (zerop y))
- (inst test x x)) ; smaller instruction
- (t
- (inst cmp x (fixnumize y))))
+ (inst test x x)) ; smaller instruction
+ (t
+ (inst cmp x (fixnumize y))))
(inst jmp (if not-p :ne :e) target)))
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
(define-vop (merge-bits)
(:translate merge-bits)
(:args (shift :scs (signed-reg unsigned-reg) :target ecx)
- (prev :scs (unsigned-reg) :target result)
- (next :scs (unsigned-reg)))
+ (prev :scs (unsigned-reg) :target result)
+ (next :scs (unsigned-reg)))
(:arg-types tagged-num unsigned-num unsigned-num)
(:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
(:results (result :scs (unsigned-reg) :from (:argument 1)))
(define-vop (shift-towards-someplace)
(:policy :fast-safe)
(:args (num :scs (unsigned-reg) :target r)
- (amount :scs (signed-reg) :target ecx))
+ (amount :scs (signed-reg) :target ecx))
(:arg-types unsigned-num tagged-num)
(:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (r :scs (unsigned-reg) :from (:argument 0)))
(define-vop (fast-ash-left-mod64/unsigned=>unsigned
fast-ash-left/unsigned=>unsigned))
(deftransform ash-left-mod64 ((integer count)
- ((unsigned-byte 64) (unsigned-byte 6)))
+ ((unsigned-byte 64) (unsigned-byte 6)))
(when (sb!c::constant-lvar-p count)
(sb!c::give-up-ir1-transform))
'(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
(define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
(when (and (<= width 64)
- (constant-lvar-p scale)
- (constant-lvar-p disp))
+ (constant-lvar-p scale)
+ (constant-lvar-p disp))
(cut-to-width base :unsigned width)
(cut-to-width index :unsigned width)
'sb!vm::%lea-mod64))
(define-modular-fun-optimizer %lea ((base index scale disp) :signed :width width)
(when (and (<= width 61)
- (constant-lvar-p scale)
- (constant-lvar-p disp))
+ (constant-lvar-p scale)
+ (constant-lvar-p disp))
(cut-to-width base :signed width)
(cut-to-width index :signed width)
'sb!vm::%lea-smod61))
(progn
(defun sb!vm::%lea-mod64 (base index scale disp)
(let ((base (logand base #xffffffffffffffff))
- (index (logand index #xffffffffffffffff)))
+ (index (logand index #xffffffffffffffff)))
;; can't use modular version of %LEA, as we only have VOPs for
;; constant SCALE and DISP.
(ldb (byte 64 0) (+ base (* index scale) disp))))
(in-package "SB!VM")
(define-vop (%lea-mod64/unsigned=>unsigned
- %lea/unsigned=>unsigned)
+ %lea/unsigned=>unsigned)
(:translate %lea-mod64))
(define-vop (%lea-smod61/fixnum=>fixnum
- %lea/fixnum=>fixnum)
+ %lea/fixnum=>fixnum)
(:translate %lea-smod61))
;;; logical operations
(define-vop (lognot-mod64/unsigned=>unsigned)
(:translate lognot-mod64)
(:args (x :scs (unsigned-reg unsigned-stack) :target r
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is r unsigned-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
(:arg-types unsigned-num)
(:results (r :scs (unsigned-reg)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is r unsigned-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
(:result-types unsigned-num)
(:policy :fast-safe)
(:generator 1
(:translate sb!bignum:%add-with-carry)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg) :target result)
- (b :scs (unsigned-reg unsigned-stack) :to :eval)
- (c :scs (any-reg) :target temp))
+ (b :scs (unsigned-reg unsigned-stack) :to :eval)
+ (c :scs (any-reg) :target temp))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
(:results (result :scs (unsigned-reg) :from (:argument 0))
- (carry :scs (unsigned-reg)))
+ (carry :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 4
(move result a)
(:translate sb!bignum:%subtract-with-borrow)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg) :to :eval :target result)
- (b :scs (unsigned-reg unsigned-stack) :to :result)
- (c :scs (any-reg control-stack)))
+ (b :scs (unsigned-reg unsigned-stack) :to :result)
+ (c :scs (any-reg control-stack)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg) :from :eval)
- (borrow :scs (unsigned-reg)))
+ (borrow :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 5
(inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg unsigned-stack))
- (carry-in :scs (unsigned-reg unsigned-stack)))
+ (y :scs (unsigned-reg unsigned-stack))
+ (carry-in :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
- :to (:result 1) :target lo) eax)
+ :to (:result 1) :target lo) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
- :to (:result 0) :target hi) edx)
+ :to (:result 0) :target hi) edx)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 20
(move eax x)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg unsigned-stack))
- (prev :scs (unsigned-reg unsigned-stack))
- (carry-in :scs (unsigned-reg unsigned-stack)))
+ (y :scs (unsigned-reg unsigned-stack))
+ (prev :scs (unsigned-reg unsigned-stack))
+ (carry-in :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
- :to (:result 1) :target lo) eax)
+ :to (:result 1) :target lo) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
- :to (:result 0) :target hi) edx)
+ :to (:result 0) :target hi) edx)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 20
(move eax x)
(:translate sb!bignum:%multiply)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg unsigned-stack)))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
- :to (:result 1) :target lo) eax)
+ :to (:result 1) :target lo) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
- :to (:result 0) :target hi) edx)
+ :to (:result 0) :target hi) edx)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 20
(move eax x)
(:args (fixnum :scs (any-reg control-stack) :target digit))
(:arg-types tagged-num)
(:results (digit :scs (unsigned-reg)
- :load-if (not (and (sc-is fixnum control-stack)
- (sc-is digit unsigned-stack)
- (location= fixnum digit)))))
+ :load-if (not (and (sc-is fixnum control-stack)
+ (sc-is digit unsigned-stack)
+ (location= fixnum digit)))))
(:result-types unsigned-num)
(:generator 1
(move digit fixnum)
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (div-high :scs (unsigned-reg) :target edx)
- (div-low :scs (unsigned-reg) :target eax)
- (divisor :scs (unsigned-reg unsigned-stack)))
+ (div-low :scs (unsigned-reg) :target eax)
+ (divisor :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
- :to (:result 0) :target quo) eax)
+ :to (:result 0) :target quo) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
- :to (:result 1) :target rem) edx)
+ :to (:result 1) :target rem) edx)
(:results (quo :scs (unsigned-reg))
- (rem :scs (unsigned-reg)))
+ (rem :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 300
(move edx div-high)
(:args (digit :scs (unsigned-reg unsigned-stack) :target res))
(:arg-types unsigned-num)
(:results (res :scs (any-reg signed-reg)
- :load-if (not (and (sc-is digit unsigned-stack)
- (sc-is res control-stack signed-stack)
- (location= digit res)))))
+ :load-if (not (and (sc-is digit unsigned-stack)
+ (sc-is res control-stack signed-stack)
+ (location= digit res)))))
(:result-types signed-num)
(:generator 1
(move res digit)
(:translate sb!bignum:%ashr)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg unsigned-stack) :target result)
- (count :scs (unsigned-reg) :target ecx))
+ (count :scs (unsigned-reg) :target ecx))
(:arg-types unsigned-num positive-fixnum)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (result :scs (unsigned-reg) :from (:argument 0)
- :load-if (not (and (sc-is result unsigned-stack)
- (location= digit result)))))
+ :load-if (not (and (sc-is result unsigned-stack)
+ (location= digit result)))))
(:result-types unsigned-num)
(:generator 1
(move result digit)
(give-up-ir1-transform))))
(deftransform * ((x y)
- ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
- (unsigned-byte 64))
+ ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
+ (unsigned-byte 64))
"recode as leas, shifts and adds"
(let ((y (lvar-value y)))
(*-transformer y)))
(*-transformer y)))
(deftransform * ((x y)
- ((signed-byte 61) (constant-arg (unsigned-byte 64)))
- (signed-byte 61))
+ ((signed-byte 61) (constant-arg (unsigned-byte 64)))
+ (signed-byte 61))
"recode as leas, shifts and adds"
(let ((y (lvar-value y)))
(*-transformer y)))
(:translate make-array-header)
(:policy :fast-safe)
(:args (type :scs (any-reg))
- (rank :scs (any-reg)))
+ (rank :scs (any-reg)))
(:arg-types positive-fixnum positive-fixnum)
(:temporary (:sc any-reg :to :eval) bytes)
(:temporary (:sc any-reg :to :result) header)
(:node-var node)
(:generator 13
(inst lea bytes
- (make-ea :qword :base rank
- :disp (+ (* (1+ array-dimensions-offset) n-word-bytes)
- lowtag-mask)))
+ (make-ea :qword :base rank
+ :disp (+ (* (1+ array-dimensions-offset) n-word-bytes)
+ lowtag-mask)))
(inst and bytes (lognot lowtag-mask))
(inst lea header (make-ea :qword :base rank
- :disp (fixnumize (1- array-dimensions-offset))))
+ :disp (fixnumize (1- array-dimensions-offset))))
(inst shl header n-widetag-bits)
(inst or header type)
(inst shr header (1- n-lowtag-bits))
(:translate %check-bound)
(:policy :fast-safe)
(:args (array :scs (descriptor-reg))
- (bound :scs (any-reg descriptor-reg))
- (index :scs (any-reg descriptor-reg) :target result))
+ (bound :scs (any-reg descriptor-reg))
+ (index :scs (any-reg descriptor-reg) :target result))
; (:arg-types * positive-fixnum tagged-num)
(:results (result :scs (any-reg descriptor-reg)))
; (:result-types positive-fixnum)
(:save-p :compute-only)
(:generator 5
(let ((error (generate-error-code vop invalid-array-index-error
- array bound index))
- (index (if (sc-is index immediate)
- (fixnumize (tn-value index))
- index)))
+ array bound index))
+ (index (if (sc-is index immediate)
+ (fixnumize (tn-value index))
+ index)))
(inst cmp bound index)
;; We use below-or-equal even though it's an unsigned test,
;; because negative indexes appear as large unsigned numbers.
;; Therefore, we get the <0 and >=bound test all rolled into one.
(inst jmp :be error)
(unless (and (tn-p index) (location= result index))
- (inst mov result index)))))
+ (inst mov result index)))))
\f
;;;; accessors/setters
;;; whose elements are represented in integer registers and are built
;;; out of 8, 16, or 32 bit elements.
(macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
- `(progn
- (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
- ,type vector-data-offset other-pointer-lowtag ,scs
- ,element-type data-vector-ref)
- (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
- ,type vector-data-offset other-pointer-lowtag ,scs
- ,element-type data-vector-set)))
- )
+ `(progn
+ (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
+ ,type vector-data-offset other-pointer-lowtag ,scs
+ ,element-type data-vector-ref)
+ (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
+ ,type vector-data-offset other-pointer-lowtag ,scs
+ ,element-type data-vector-set)))
+ )
(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
(def-full-data-vector-frobs simple-array-unsigned-byte-64 unsigned-num
unsigned-reg)
;;;; bit, 2-bit, and 4-bit vectors
(macrolet ((def-small-data-vector-frobs (type bits)
- (let* ((elements-per-word (floor n-word-bits bits))
- (bit-shift (1- (integer-length elements-per-word))))
+ (let* ((elements-per-word (floor n-word-bits bits))
+ (bit-shift (1- (integer-length elements-per-word))))
`(progn
(define-vop (,(symbolicate 'data-vector-ref/ type))
- (:note "inline array access")
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
- (:arg-types ,type positive-fixnum)
- (:results (result :scs (unsigned-reg) :from (:argument 0)))
- (:result-types positive-fixnum)
- (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
- (:generator 20
- (move ecx index)
- (inst shr ecx ,bit-shift)
- (inst mov result
- (make-ea :qword :base object :index ecx :scale n-word-bytes
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (move ecx index)
- (inst and ecx ,(1- elements-per-word))
- ,@(unless (= bits 1)
- `((inst shl ecx ,(1- (integer-length bits)))))
- (inst shr result :cl)
- (inst and result ,(1- (ash 1 bits)))))
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (result :scs (unsigned-reg) :from (:argument 0)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
+ (:generator 20
+ (move ecx index)
+ (inst shr ecx ,bit-shift)
+ (inst mov result
+ (make-ea :qword :base object :index ecx :scale n-word-bytes
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
+ (move ecx index)
+ (inst and ecx ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst shl ecx ,(1- (integer-length bits)))))
+ (inst shr result :cl)
+ (inst and result ,(1- (ash 1 bits)))))
(define-vop (,(symbolicate 'data-vector-ref-c/ type))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:arg-types ,type (:constant low-index))
- (:info index)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:generator 15
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- (loadw result object (+ word vector-data-offset)
- other-pointer-lowtag)
- (unless (zerop extra)
- (inst shr result (* extra ,bits)))
- (unless (= extra ,(1- elements-per-word))
- (inst and result ,(1- (ash 1 bits)))))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:arg-types ,type (:constant low-index))
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 15
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (loadw result object (+ word vector-data-offset)
+ other-pointer-lowtag)
+ (unless (zerop extra)
+ (inst shr result (* extra ,bits)))
+ (unless (= extra ,(1- elements-per-word))
+ (inst and result ,(1- (ash 1 bits)))))))
(define-vop (,(symbolicate 'data-vector-set/ type))
- (:note "inline array store")
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :target ptr)
- (index :scs (unsigned-reg) :target ecx)
- (value :scs (unsigned-reg immediate) :target result))
- (:arg-types ,type positive-fixnum positive-fixnum)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:sc unsigned-reg) word-index)
- (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
- (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
- ecx)
- (:generator 25
- (move word-index index)
- (inst shr word-index ,bit-shift)
- (inst lea ptr
- (make-ea :qword :base object :index word-index
- :scale n-word-bytes
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (loadw old ptr)
- (move ecx index)
- (inst and ecx ,(1- elements-per-word))
- ,@(unless (= bits 1)
- `((inst shl ecx ,(1- (integer-length bits)))))
- (inst ror old :cl)
- (unless (and (sc-is value immediate)
- (= (tn-value value) ,(1- (ash 1 bits))))
- (inst and old ,(lognot (1- (ash 1 bits)))))
- (sc-case value
- (immediate
- (unless (zerop (tn-value value))
- (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
- (unsigned-reg
- (inst or old value)))
- (inst rol old :cl)
- (storew old ptr)
- (sc-case value
- (immediate
- (inst mov result (tn-value value)))
- (unsigned-reg
- (move result value)))))
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :target ptr)
+ (index :scs (unsigned-reg) :target ecx)
+ (value :scs (unsigned-reg immediate) :target result))
+ (:arg-types ,type positive-fixnum positive-fixnum)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg) word-index)
+ (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
+ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
+ ecx)
+ (:generator 25
+ (move word-index index)
+ (inst shr word-index ,bit-shift)
+ (inst lea ptr
+ (make-ea :qword :base object :index word-index
+ :scale n-word-bytes
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
+ (loadw old ptr)
+ (move ecx index)
+ (inst and ecx ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst shl ecx ,(1- (integer-length bits)))))
+ (inst ror old :cl)
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (inst and old ,(lognot (1- (ash 1 bits)))))
+ (sc-case value
+ (immediate
+ (unless (zerop (tn-value value))
+ (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
+ (unsigned-reg
+ (inst or old value)))
+ (inst rol old :cl)
+ (storew old ptr)
+ (sc-case value
+ (immediate
+ (inst mov result (tn-value value)))
+ (unsigned-reg
+ (move result value)))))
(define-vop (,(symbolicate 'data-vector-set-c/ type))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (value :scs (unsigned-reg immediate) :target result))
- (:arg-types ,type (:constant low-index) positive-fixnum)
- (:temporary (:sc unsigned-reg) mask-tn)
- (:info index)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:sc unsigned-reg :to (:result 0)) old)
- (:generator 20
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- (inst mov old
- (make-ea :qword :base object
- :disp (- (* (+ word vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag)))
- (sc-case value
- (immediate
- (let* ((value (tn-value value))
- (mask ,(1- (ash 1 bits)))
- (shift (* extra ,bits)))
- (unless (= value mask)
- (inst mov mask-tn (ldb (byte 64 0)
- (lognot (ash mask shift))))
- (inst and old mask-tn))
- (unless (zerop value)
- (inst mov mask-tn (ash value shift))
- (inst or old mask-tn))))
- (unsigned-reg
- (let ((shift (* extra ,bits)))
- (unless (zerop shift)
- (inst ror old shift))
- (inst mov mask-tn (lognot ,(1- (ash 1 bits))))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg immediate) :target result))
+ (:arg-types ,type (:constant low-index) positive-fixnum)
+ (:temporary (:sc unsigned-reg) mask-tn)
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg :to (:result 0)) old)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (inst mov old
+ (make-ea :qword :base object
+ :disp (- (* (+ word vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (sc-case value
+ (immediate
+ (let* ((value (tn-value value))
+ (mask ,(1- (ash 1 bits)))
+ (shift (* extra ,bits)))
+ (unless (= value mask)
+ (inst mov mask-tn (ldb (byte 64 0)
+ (lognot (ash mask shift))))
+ (inst and old mask-tn))
+ (unless (zerop value)
+ (inst mov mask-tn (ash value shift))
+ (inst or old mask-tn))))
+ (unsigned-reg
+ (let ((shift (* extra ,bits)))
+ (unless (zerop shift)
+ (inst ror old shift))
+ (inst mov mask-tn (lognot ,(1- (ash 1 bits))))
(inst and old mask-tn)
(inst or old value)
- (unless (zerop shift)
+ (unless (zerop shift)
(inst rol old shift)))))
- (inst mov (make-ea :qword :base object
- :disp (- (* (+ word vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag))
- old)
- (sc-case value
- (immediate
- (inst mov result (tn-value value)))
- (unsigned-reg
- (move result value))))))))))
+ (inst mov (make-ea :qword :base object
+ :disp (- (* (+ word vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag))
+ old)
+ (sc-case value
+ (immediate
+ (inst mov result (tn-value value)))
+ (unsigned-reg
+ (move result value))))))))))
(def-small-data-vector-frobs simple-bit-vector 1)
(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
(def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-single-float positive-fixnum)
(:temporary (:sc unsigned-reg) dword-index)
(:results (value :scs (single-reg)))
(move dword-index index)
(inst shr dword-index 1)
(inst movss value (make-ea :dword :base object :index dword-index
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))))
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-single-float)
(:note "inline array access")
(:result-types single-float)
(:generator 4
(inst movss value (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 4 index))
- other-pointer-lowtag)))))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (single-reg) :target result))
(:arg-types simple-array-single-float positive-fixnum single-float)
(:temporary (:sc unsigned-reg) dword-index)
(:results (result :scs (single-reg)))
(move dword-index index)
(inst shr dword-index 1)
(inst movss (make-ea :dword :base object :index dword-index
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag))
- value)
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag))
+ value)
(unless (location= result value)
(inst movss result value))))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs (single-reg) :target result))
+ (value :scs (single-reg) :target result))
(:info index)
(:arg-types simple-array-single-float (:constant low-index)
- single-float)
+ single-float)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 4
(inst movss (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 4 index))
- other-pointer-lowtag))
- value)
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag))
+ value)
(unless (location= result value)
(inst movss result value))))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-double-float positive-fixnum)
(:results (value :scs (double-reg)))
(:result-types double-float)
(:generator 7
(inst movsd value (make-ea :qword :base object :index index :scale 1
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))))
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-double-float)
(:note "inline array access")
(:result-types double-float)
(:generator 6
(inst movsd value (make-ea :qword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag)))))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (double-reg) :target result))
(:arg-types simple-array-double-float positive-fixnum double-float)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 20
(inst movsd (make-ea :qword :base object :index index :scale 1
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag))
- value)
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag))
+ value)
(unless (location= result value)
(inst movsd result value))))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs (double-reg) :target result))
+ (value :scs (double-reg) :target result))
(:info index)
(:arg-types simple-array-double-float (:constant low-index)
- double-float)
+ double-float)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 19
(inst movsd (make-ea :qword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag))
- value)
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag))
+ value)
(unless (location= result value)
(inst movsd result value))))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-complex-single-float positive-fixnum)
(:results (value :scs (complex-single-reg)))
(:result-types complex-single-float)
(:generator 5
(let ((real-tn (complex-single-reg-real-tn value)))
(inst movss real-tn (make-ea :dword :base object :index index
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag))))
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag))))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(inst movss imag-tn (make-ea :dword :base object :index index
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- 4)
- other-pointer-lowtag))))))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ 4)
+ other-pointer-lowtag))))))
(define-vop (data-vector-ref-c/simple-array-complex-single-float)
(:note "inline array access")
(:generator 4
(let ((real-tn (complex-single-reg-real-tn value)))
(inst movss real-tn (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag))))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag))))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(inst movss imag-tn (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index) 4)
- other-pointer-lowtag))))))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index) 4)
+ other-pointer-lowtag))))))
(define-vop (data-vector-set/simple-array-complex-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-single-reg) :target result))
(:arg-types simple-array-complex-single-float positive-fixnum
- complex-single-float)
+ complex-single-float)
(:results (result :scs (complex-single-reg)))
(:result-types complex-single-float)
(:generator 5
(let ((value-real (complex-single-reg-real-tn value))
- (result-real (complex-single-reg-real-tn result)))
+ (result-real (complex-single-reg-real-tn result)))
(inst movss (make-ea :dword :base object :index index
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag))
- value-real)
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag))
+ value-real)
(unless (location= value-real result-real)
- (inst movss result-real value-real)))
+ (inst movss result-real value-real)))
(let ((value-imag (complex-single-reg-imag-tn value))
- (result-imag (complex-single-reg-imag-tn result)))
+ (result-imag (complex-single-reg-imag-tn result)))
(inst movss (make-ea :dword :base object :index index
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- 4)
- other-pointer-lowtag))
- value-imag)
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ 4)
+ other-pointer-lowtag))
+ value-imag)
(unless (location= value-imag result-imag)
- (inst movss result-imag value-imag)))))
+ (inst movss result-imag value-imag)))))
(define-vop (data-vector-set-c/simple-array-complex-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs (complex-single-reg) :target result))
+ (value :scs (complex-single-reg) :target result))
(:info index)
(:arg-types simple-array-complex-single-float (:constant low-index)
- complex-single-float)
+ complex-single-float)
(:results (result :scs (complex-single-reg)))
(:result-types complex-single-float)
(:generator 4
(let ((value-real (complex-single-reg-real-tn value))
- (result-real (complex-single-reg-real-tn result)))
+ (result-real (complex-single-reg-real-tn result)))
(inst movss (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag))
- value-real)
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag))
+ value-real)
(unless (location= value-real result-real)
- (inst movss result-real value-real)))
+ (inst movss result-real value-real)))
(let ((value-imag (complex-single-reg-imag-tn value))
- (result-imag (complex-single-reg-imag-tn result)))
+ (result-imag (complex-single-reg-imag-tn result)))
(inst movss (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index) 4)
- other-pointer-lowtag))
- value-imag)
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index) 4)
+ other-pointer-lowtag))
+ value-imag)
(unless (location= value-imag result-imag)
- (inst movss result-imag value-imag)))))
+ (inst movss result-imag value-imag)))))
(define-vop (data-vector-ref/simple-array-complex-double-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-complex-double-float positive-fixnum)
(:results (value :scs (complex-double-reg)))
(:result-types complex-double-float)
(:generator 7
(let ((real-tn (complex-double-reg-real-tn value)))
(inst movsd real-tn (make-ea :dword :base object :index index :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag))))
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag))))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(inst movsd imag-tn (make-ea :dword :base object :index index :scale 2
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- 8)
- other-pointer-lowtag))))))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ 8)
+ other-pointer-lowtag))))))
(define-vop (data-vector-ref-c/simple-array-complex-double-float)
(:note "inline array access")
(:result-types complex-double-float)
(:generator 6
(let ((real-tn (complex-double-reg-real-tn value)))
- (inst movsd real-tn (make-ea :qword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 16 index))
- other-pointer-lowtag))))
+ (inst movsd real-tn (make-ea :qword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 16 index))
+ other-pointer-lowtag))))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(inst movsd imag-tn (make-ea :qword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 16 index) 8)
- other-pointer-lowtag))))))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 16 index) 8)
+ other-pointer-lowtag))))))
(define-vop (data-vector-set/simple-array-complex-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-double-reg) :target result))
(:arg-types simple-array-complex-double-float positive-fixnum
- complex-double-float)
+ complex-double-float)
(:results (result :scs (complex-double-reg)))
(:result-types complex-double-float)
(:generator 20
(let ((value-real (complex-double-reg-real-tn value))
- (result-real (complex-double-reg-real-tn result)))
+ (result-real (complex-double-reg-real-tn result)))
(inst movsd (make-ea :qword :base object :index index :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag))
- value-real)
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag))
+ value-real)
(unless (location= value-real result-real)
- (inst movsd result-real value-real)))
+ (inst movsd result-real value-real)))
(let ((value-imag (complex-double-reg-imag-tn value))
- (result-imag (complex-double-reg-imag-tn result)))
+ (result-imag (complex-double-reg-imag-tn result)))
(inst movsd (make-ea :qword :base object :index index :scale 2
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- 8)
- other-pointer-lowtag))
- value-imag)
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ 8)
+ other-pointer-lowtag))
+ value-imag)
(unless (location= value-imag result-imag)
- (inst movsd result-imag value-imag)))))
+ (inst movsd result-imag value-imag)))))
(define-vop (data-vector-set-c/simple-array-complex-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs (complex-double-reg) :target result))
+ (value :scs (complex-double-reg) :target result))
(:info index)
(:arg-types simple-array-complex-double-float (:constant low-index)
- complex-double-float)
+ complex-double-float)
(:results (result :scs (complex-double-reg)))
(:result-types complex-double-float)
(:generator 19
(let ((value-real (complex-double-reg-real-tn value))
- (result-real (complex-double-reg-real-tn result)))
+ (result-real (complex-double-reg-real-tn result)))
(inst movsd (make-ea :qword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 16 index))
- other-pointer-lowtag))
- value-real)
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 16 index))
+ other-pointer-lowtag))
+ value-real)
(unless (location= value-real result-real)
- (inst movsd result-real value-real)))
+ (inst movsd result-real value-real)))
(let ((value-imag (complex-double-reg-imag-tn value))
- (result-imag (complex-double-reg-imag-tn result)))
+ (result-imag (complex-double-reg-imag-tn result)))
(inst movsd (make-ea :qword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 16 index) 8)
- other-pointer-lowtag))
- value-imag)
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 16 index) 8)
+ other-pointer-lowtag))
+ value-imag)
(unless (location= value-imag result-imag)
- (inst movsd result-imag value-imag)))))
+ (inst movsd result-imag value-imag)))))
\f
(:results (value :scs (unsigned-reg signed-reg)))
(:result-types positive-fixnum)
(:generator 5
- (inst movzx value
- (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (inst movzx value
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
(:translate data-vector-ref)
(:policy :fast-safe)
(:results (value :scs (unsigned-reg signed-reg)))
(:result-types positive-fixnum)
(:generator 4
- (inst movzx value
- (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag)))))
+ (inst movzx value
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target eax))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
(:arg-types ,ptype positive-fixnum positive-fixnum)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 2) :to (:result 0))
- eax)
+ :from (:argument 2) :to (:result 0))
+ eax)
(:results (result :scs (unsigned-reg signed-reg)))
(:result-types positive-fixnum)
(:generator 5
- (move eax value)
- (inst mov (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- al-tn)
- (move result eax)))
+ (move eax value)
+ (inst mov (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ al-tn)
+ (move result eax)))
(define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target eax))
+ (value :scs (unsigned-reg signed-reg) :target eax))
(:info index)
(:arg-types ,ptype (:constant low-index)
- positive-fixnum)
+ positive-fixnum)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 1) :to (:result 0))
- eax)
+ :from (:argument 1) :to (:result 0))
+ eax)
(:results (result :scs (unsigned-reg signed-reg)))
(:result-types positive-fixnum)
(:generator 4
- (move eax value)
- (inst mov (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag))
- al-tn)
- (move result eax))))))
+ (move eax value)
+ (inst mov (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag))
+ al-tn)
+ (move result eax))))))
(define-data-vector-frobs simple-array-unsigned-byte-7)
(define-data-vector-frobs simple-array-unsigned-byte-8))
(macrolet ((define-data-vector-frobs (ptype)
`(progn
(define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
- (:arg-types ,ptype positive-fixnum)
- (:results (value :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 5
- (inst movzx value
- (make-ea :word :base object :index index :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,ptype positive-fixnum)
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (inst movzx value
+ (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:info index)
- (:arg-types ,ptype (:constant low-index))
- (:results (value :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 4
- (inst movzx value
- (make-ea :word :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
- other-pointer-lowtag)))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,ptype (:constant low-index))
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (inst movzx value
+ (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target eax))
- (:arg-types ,ptype positive-fixnum positive-fixnum)
- (:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 2) :to (:result 0))
- eax)
- (:results (result :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 5
- (move eax value)
- (inst mov (make-ea :word :base object :index index :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- ax-tn)
- (move result eax)))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
+ (:arg-types ,ptype positive-fixnum positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 2) :to (:result 0))
+ eax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (move eax value)
+ (inst mov (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ ax-tn)
+ (move result eax)))
(define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target eax))
- (:info index)
- (:arg-types ,ptype (:constant low-index)
- positive-fixnum)
- (:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 1) :to (:result 0))
- eax)
- (:results (result :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 4
- (move eax value)
- (inst mov (make-ea :word :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 2 index))
- other-pointer-lowtag))
- ax-tn)
- (move result eax))))))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
+ (:info index)
+ (:arg-types ,ptype (:constant low-index)
+ positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 1) :to (:result 0))
+ eax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (move eax value)
+ (inst mov (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 2 index))
+ other-pointer-lowtag))
+ ax-tn)
+ (move result eax))))))
(define-data-vector-frobs simple-array-unsigned-byte-15)
(define-data-vector-frobs simple-array-unsigned-byte-16))
(macrolet ((define-data-vector-frobs (ptype)
`(progn
(define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
- (:arg-types ,ptype positive-fixnum)
- (:results (value :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 5
- (inst movzxd value
- (make-ea :dword :base object :index index :scale 4
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,ptype positive-fixnum)
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (inst movzxd value
+ (make-ea :dword :base object :index index :scale 4
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:info index)
- (:arg-types ,ptype (:constant low-index))
- (:results (value :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 4
- (inst movzxd value
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 4 index))
- other-pointer-lowtag)))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,ptype (:constant low-index))
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (inst movzxd value
+ (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target rax))
- (:arg-types ,ptype positive-fixnum positive-fixnum)
- (:temporary (:sc unsigned-reg :offset rax-offset :target result
- :from (:argument 2) :to (:result 0))
- rax)
- (:results (result :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 5
- (move rax value)
- (inst mov (make-ea :dword :base object :index index :scale 4
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- eax-tn)
- (move result rax)))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target rax))
+ (:arg-types ,ptype positive-fixnum positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset rax-offset :target result
+ :from (:argument 2) :to (:result 0))
+ rax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (move rax value)
+ (inst mov (make-ea :dword :base object :index index :scale 4
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ eax-tn)
+ (move result rax)))
(define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target rax))
- (:info index)
- (:arg-types ,ptype (:constant low-index)
- positive-fixnum)
- (:temporary (:sc unsigned-reg :offset rax-offset :target result
- :from (:argument 1) :to (:result 0))
- rax)
- (:results (result :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 4
- (move rax value)
- (inst mov (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 4 index))
- other-pointer-lowtag))
- eax-tn)
- (move result rax))))))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target rax))
+ (:info index)
+ (:arg-types ,ptype (:constant low-index)
+ positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset rax-offset :target result
+ :from (:argument 1) :to (:result 0))
+ rax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (move rax value)
+ (inst mov (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag))
+ eax-tn)
+ (move result rax))))))
(define-data-vector-frobs simple-array-unsigned-byte-32)
(define-data-vector-frobs simple-array-unsigned-byte-31))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:arg-types simple-base-string positive-fixnum)
(:results (value :scs (character-reg)))
(:result-types character)
(:generator 5
(inst movzx value
- (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-base-string)
(:translate data-vector-ref)
(:result-types character)
(:generator 4
(inst movzx value
- (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-base-string)
(:translate data-vector-set)
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:arg-types simple-base-string positive-fixnum)
(:results (value :scs (character-reg)))
(:result-types character)
(:generator 5
(inst mov value
- (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-base-string)
(:translate data-vector-ref)
(:result-types character)
(:generator 4
(inst mov value
- (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-base-string)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (character-reg) :target result))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (character-reg) :target result))
(:arg-types simple-base-string positive-fixnum character)
(:results (result :scs (character-reg)))
(:result-types character)
(:generator 5
(inst mov (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- value)
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ value)
(move result value)))
(define-vop (data-vector-set-c/simple-base-string)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (character-reg)))
+ (value :scs (character-reg)))
(:info index)
(:arg-types simple-base-string (:constant low-index) character)
(:results (result :scs (character-reg)))
(:result-types character)
(:generator 4
(inst mov (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag))
- value)
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag))
+ value)
(move result value)))
) ; PROGN
(macrolet ((define-data-vector-frobs (ptype)
`(progn
(define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
- (:arg-types ,ptype positive-fixnum)
- (:results (value :scs (character-reg)))
- (:result-types character)
- (:generator 5
- (inst movzxd value
- (make-ea :dword :base object :index index :scale 4
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,ptype positive-fixnum)
+ (:results (value :scs (character-reg)))
+ (:result-types character)
+ (:generator 5
+ (inst movzxd value
+ (make-ea :dword :base object :index index :scale 4
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:info index)
- (:arg-types ,ptype (:constant low-index))
- (:results (value :scs (character-reg)))
- (:result-types character)
- (:generator 4
- (inst movzxd value
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 4 index))
- other-pointer-lowtag)))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,ptype (:constant low-index))
+ (:results (value :scs (character-reg)))
+ (:result-types character)
+ (:generator 4
+ (inst movzxd value
+ (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (character-reg) :target rax))
- (:arg-types ,ptype positive-fixnum character)
- (:temporary (:sc character-reg :offset rax-offset :target result
- :from (:argument 2) :to (:result 0))
- rax)
- (:results (result :scs (character-reg)))
- (:result-types character)
- (:generator 5
- (move rax value)
- (inst mov (make-ea :dword :base object :index index :scale 4
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- eax-tn)
- (move result rax)))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (character-reg) :target rax))
+ (:arg-types ,ptype positive-fixnum character)
+ (:temporary (:sc character-reg :offset rax-offset :target result
+ :from (:argument 2) :to (:result 0))
+ rax)
+ (:results (result :scs (character-reg)))
+ (:result-types character)
+ (:generator 5
+ (move rax value)
+ (inst mov (make-ea :dword :base object :index index :scale 4
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ eax-tn)
+ (move result rax)))
(define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (character-reg) :target rax))
- (:info index)
- (:arg-types ,ptype (:constant low-index) character)
- (:temporary (:sc character-reg :offset rax-offset :target result
- :from (:argument 1) :to (:result 0))
- rax)
- (:results (result :scs (character-reg)))
- (:result-types character)
- (:generator 4
- (move rax value)
- (inst mov (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 4 index))
- other-pointer-lowtag))
- eax-tn)
- (move result rax))))))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (character-reg) :target rax))
+ (:info index)
+ (:arg-types ,ptype (:constant low-index) character)
+ (:temporary (:sc character-reg :offset rax-offset :target result
+ :from (:argument 1) :to (:result 0))
+ rax)
+ (:results (result :scs (character-reg)))
+ (:result-types character)
+ (:generator 4
+ (move rax value)
+ (inst mov (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag))
+ eax-tn)
+ (move result rax))))))
(define-data-vector-frobs simple-character-string))
\f
;;; signed-byte-8
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:arg-types simple-array-signed-byte-8 positive-fixnum)
(:results (value :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(inst movsx value
- (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-signed-byte-8)
(:translate data-vector-ref)
(:result-types tagged-num)
(:generator 4
(inst movsx value
- (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-signed-byte-8)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (signed-reg) :target eax))
(:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 2) :to (:result 0))
- eax)
+ :from (:argument 2) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(move eax value)
(inst mov (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- al-tn)
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ al-tn)
(move result eax)))
(define-vop (data-vector-set-c/simple-array-signed-byte-8)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (value :scs (signed-reg) :target eax))
(:info index)
(:arg-types simple-array-signed-byte-8 (:constant low-index)
- tagged-num)
+ tagged-num)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 1) :to (:result 0))
- eax)
+ :from (:argument 1) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 4
(move eax value)
(inst mov (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag))
- al-tn)
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag))
+ al-tn)
(move result eax)))
;;; signed-byte-16
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:arg-types simple-array-signed-byte-16 positive-fixnum)
(:results (value :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(inst movsx value
- (make-ea :word :base object :index index :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-signed-byte-16)
(:translate data-vector-ref)
(:result-types tagged-num)
(:generator 4
(inst movsx value
- (make-ea :word :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 2 index))
- other-pointer-lowtag)))))
+ (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 2 index))
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-signed-byte-16)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (signed-reg) :target eax))
(:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
(:temporary (:sc signed-reg :offset eax-offset :target result
- :from (:argument 2) :to (:result 0))
- eax)
+ :from (:argument 2) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(move eax value)
(inst mov (make-ea :word :base object :index index :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- ax-tn)
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ ax-tn)
(move result eax)))
(define-vop (data-vector-set-c/simple-array-signed-byte-16)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (value :scs (signed-reg) :target eax))
(:info index)
(:arg-types simple-array-signed-byte-16 (:constant low-index) tagged-num)
(:temporary (:sc signed-reg :offset eax-offset :target result
- :from (:argument 1) :to (:result 0))
- eax)
+ :from (:argument 1) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 4
(move eax value)
(inst mov
- (make-ea :word :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 2 index))
- other-pointer-lowtag))
- ax-tn)
+ (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 2 index))
+ other-pointer-lowtag))
+ ax-tn)
(move result eax)))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:arg-types simple-array-signed-byte-32 positive-fixnum)
(:results (value :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(inst movsxd value
- (make-ea :dword :base object :index index :scale 4
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (make-ea :dword :base object :index index :scale 4
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-signed-byte-32)
(:translate data-vector-ref)
(:result-types tagged-num)
(:generator 4
(inst movsxd value
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 4 index))
- other-pointer-lowtag)))))
+ (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-signed-byte-32)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (signed-reg) :target eax))
(:arg-types simple-array-signed-byte-32 positive-fixnum tagged-num)
(:temporary (:sc signed-reg :offset eax-offset :target result
- :from (:argument 2) :to (:result 0))
- eax)
+ :from (:argument 2) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(move eax value)
(inst mov (make-ea :dword :base object :index index :scale 4
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- eax-tn)
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ eax-tn)
(move result eax)))
(define-vop (data-vector-set-c/simple-array-signed-byte-32)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (value :scs (signed-reg) :target eax))
(:info index)
(:arg-types simple-array-signed-byte-32 (:constant low-index) tagged-num)
(:temporary (:sc signed-reg :offset eax-offset :target result
- :from (:argument 1) :to (:result 0))
- eax)
+ :from (:argument 1) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 4
(move eax value)
(inst mov
- (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 4 index))
- other-pointer-lowtag))
- rax-tn)
+ (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag))
+ rax-tn)
(move result eax)))
\f
;;; These VOPs are used for implementing float slots in structures (whose raw
;;;; complex-float raw structure slot accessors
(define-vop (raw-ref-complex-single
- data-vector-ref/simple-array-complex-single-float)
+ data-vector-ref/simple-array-complex-single-float)
(:translate %raw-ref-complex-single)
(:arg-types sb!c::raw-vector positive-fixnum))
(define-vop (raw-ref-complex-single-c
- data-vector-ref-c/simple-array-complex-single-float)
+ data-vector-ref-c/simple-array-complex-single-float)
(:translate %raw-ref-complex-single)
(:arg-types sb!c::raw-vector (:constant low-index)))
(define-vop (raw-set-complex-single
- data-vector-set/simple-array-complex-single-float)
+ data-vector-set/simple-array-complex-single-float)
(:translate %raw-set-complex-single)
(:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
(define-vop (raw-set-complex-single-c
- data-vector-set-c/simple-array-complex-single-float)
+ data-vector-set-c/simple-array-complex-single-float)
(:translate %raw-set-complex-single)
(:arg-types sb!c::raw-vector (:constant low-index)
- complex-single-float))
+ complex-single-float))
(define-vop (raw-ref-complex-double
- data-vector-ref/simple-array-complex-double-float)
+ data-vector-ref/simple-array-complex-double-float)
(:translate %raw-ref-complex-double)
(:arg-types sb!c::raw-vector positive-fixnum))
(define-vop (raw-ref-complex-double-c
- data-vector-ref-c/simple-array-complex-double-float)
+ data-vector-ref-c/simple-array-complex-double-float)
(:translate %raw-ref-complex-double)
(:arg-types sb!c::raw-vector (:constant low-index)))
(define-vop (raw-set-complex-double
- data-vector-set/simple-array-complex-double-float)
+ data-vector-set/simple-array-complex-double-float)
(:translate %raw-set-complex-double)
(:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
(define-vop (raw-set-complex-double-c
- data-vector-set-c/simple-array-complex-double-float)
+ data-vector-set-c/simple-array-complex-double-float)
(:translate %raw-set-complex-double)
(:arg-types sb!c::raw-vector (:constant low-index)
- complex-double-float))
+ complex-double-float))
;;; These vops are useful for accessing the bits of a vector
(defun my-make-wired-tn (prim-type-name sc-name offset)
(make-wired-tn (primitive-type-or-lose prim-type-name)
- (sc-number-or-lose sc-name)
- offset))
+ (sc-number-or-lose sc-name)
+ offset))
(defstruct (arg-state (:copier nil))
(register-args 0)
(defun int-arg (state prim-type reg-sc stack-sc)
(let ((reg-args (arg-state-register-args state)))
(cond ((< reg-args 6)
- (setf (arg-state-register-args state) (1+ reg-args))
- (my-make-wired-tn prim-type reg-sc
- (nth reg-args *c-call-register-arg-offsets*)))
- (t
- (let ((frame-size (arg-state-stack-frame-size state)))
- (setf (arg-state-stack-frame-size state) (1+ frame-size))
- (my-make-wired-tn prim-type stack-sc frame-size))))))
+ (setf (arg-state-register-args state) (1+ reg-args))
+ (my-make-wired-tn prim-type reg-sc
+ (nth reg-args *c-call-register-arg-offsets*)))
+ (t
+ (let ((frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ frame-size))
+ (my-make-wired-tn prim-type stack-sc frame-size))))))
(define-alien-type-method (integer :arg-tn) (type state)
(if (alien-integer-type-signed type)
(defun float-arg (state prim-type reg-sc stack-sc)
(let ((xmm-args (arg-state-xmm-args state)))
(cond ((< xmm-args 8)
- (setf (arg-state-xmm-args state) (1+ xmm-args))
- (my-make-wired-tn prim-type reg-sc
- (nth xmm-args *float-regs*)))
- (t
- (let ((frame-size (arg-state-stack-frame-size state)))
- (setf (arg-state-stack-frame-size state) (1+ frame-size))
- (my-make-wired-tn prim-type stack-sc frame-size))))))
+ (setf (arg-state-xmm-args state) (1+ xmm-args))
+ (my-make-wired-tn prim-type reg-sc
+ (nth xmm-args *float-regs*)))
+ (t
+ (let ((frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ frame-size))
+ (my-make-wired-tn prim-type stack-sc frame-size))))))
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(multiple-value-bind (ptype reg-sc)
- (if (alien-integer-type-signed type)
- (values 'signed-byte-64 'signed-reg)
- (values 'unsigned-byte-64 'unsigned-reg))
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-64 'signed-reg)
+ (values 'unsigned-byte-64 'unsigned-reg))
(my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
(define-alien-type-method (integer :naturalize-gen) (type alien)
(if (and (alien-integer-type-signed type)
- (<= (alien-type-bits type) 32))
+ (<= (alien-type-bits type) 32))
`(sign-extend ,alien)
alien))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'system-area-pointer 'sap-reg
- (result-reg-offset num-results))))
+ (result-reg-offset num-results))))
(define-alien-type-method (double-float :result-tn) (type state)
(declare (ignore type))
(when (> (length values) 2)
(error "Too many result values from c-call."))
(mapcar (lambda (type)
- (invoke-alien-type-method :result-tn type state))
- values)))
+ (invoke-alien-type-method :result-tn type state))
+ values)))
(!def-vm-support-routine make-call-out-tns (type)
(let ((arg-state (make-arg-state)))
(collect ((arg-tns))
(dolist (arg-type (alien-fun-type-arg-types type))
- (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+ (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset)
- (* (arg-state-stack-frame-size arg-state) n-word-bytes)
- (arg-tns)
- (invoke-alien-type-method :result-tn
- (alien-fun-type-result-type type)
- (make-result-state))))))
+ (* (arg-state-stack-frame-size arg-state) n-word-bytes)
+ (arg-tns)
+ (invoke-alien-type-method :result-tn
+ (alien-fun-type-result-type type)
+ (make-result-state))))))
(deftransform %alien-funcall ((function type &rest args) * * :node node)
(aver (sb!c::constant-lvar-p type))
(let* ((type (sb!c::lvar-value type))
- (env (sb!c::node-lexenv node))
+ (env (sb!c::node-lexenv node))
(arg-types (alien-fun-type-arg-types type))
(result-type (alien-fun-type-result-type type)))
(aver (= (length arg-types) (length args)))
(if (alien-integer-type-signed result-type)
'(values (unsigned 64) (signed 64))
'(values (unsigned 64) (unsigned 64)))
- env))))
+ env))))
`(lambda (function type ,@(lambda-vars))
(declare (ignore type))
(multiple-value-bind (low high)
;;; The ABI specifies that signed short/int's are returned as 32-bit
;;; values. Negative values need to be sign-extended to 64-bits (done
;;; in a :NATURALIZE-GEN alien-type-method).
-(defknown sign-extend (fixnum) fixnum (foldable flushable movable))
+(defknown sign-extend (fixnum) fixnum (foldable flushable movable))
(define-vop (sign-extend)
(:translate sign-extend)
(:result-types fixnum)
(:generator 1
(inst movsxd res
- (make-random-tn :kind :normal
- :sc (sc-or-lose 'dword-reg)
- :offset (tn-offset val)))))
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'dword-reg)
+ :offset (tn-offset val)))))
(defun sign-extend (x)
(if (logbitp 31 x)
(define-vop (call-out)
(:args (function :scs (sap-reg))
- (args :more t))
+ (args :more t))
(:results (results :more t))
(:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax)
(:ignore results)
;; ABI: AL contains amount of arguments passed in XMM registers
;; for vararg calls.
(move-immediate rax
- (loop for tn-ref = args then (tn-ref-across tn-ref)
- while tn-ref
- count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref))))
- 'float-registers)))
+ (loop for tn-ref = args then (tn-ref-across tn-ref)
+ while tn-ref
+ count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref))))
+ 'float-registers)))
(inst call function)
;; To give the debugger a clue. XX not really internal-error?
(note-this-location vop :internal-error)
;; FLOAT15 needs to contain FP zero in Lispland
- (let ((float15 (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset float15-offset)))
+ (let ((float15 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset float15-offset)))
(inst xorpd float15 float15))))
(define-vop (alloc-number-stack-space)
(aver (location= result rsp-tn))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (inst sub rsp-tn delta)))
+ (inst sub rsp-tn delta)))
;; C stack must be 16 byte aligned
(inst and rsp-tn #xfffffff0)
(move result rsp-tn)))
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (inst add rsp-tn delta)))))
+ (inst add rsp-tn delta)))))
(define-vop (alloc-alien-stack-space)
(:info amount)
(aver (not (location= result rsp-tn)))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (inst mov temp
- (make-ea :qword
- :disp (+ nil-value
- (static-symbol-offset '*alien-stack*)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
- (inst sub (make-ea :qword :base thread-base-tn
- :scale 1 :index temp) delta)))
+ (inst mov temp
+ (make-ea :qword
+ :disp (+ nil-value
+ (static-symbol-offset '*alien-stack*)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
+ (inst sub (make-ea :qword :base thread-base-tn
+ :scale 1 :index temp) delta)))
(load-tl-symbol-value result *alien-stack*))
#!-sb-thread
(:generator 0
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (inst mov temp
- (make-ea :qword
- :disp (+ nil-value
- (static-symbol-offset '*alien-stack*)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
- (inst add (make-ea :qword :base thread-base-tn :scale 1 :index temp)
- delta))))
+ (inst mov temp
+ (make-ea :qword
+ :disp (+ nil-value
+ (static-symbol-offset '*alien-stack*)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
+ (inst add (make-ea :qword :base thread-base-tn :scale 1 :index temp)
+ delta))))
#!-sb-thread
(:generator 0
(unless (zerop amount)
(declare (type unsigned-byte n))
(if (< n register-arg-count)
(make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number
- (nth n *register-arg-offsets*))
+ (nth n *register-arg-offsets*))
(make-wired-tn *backend-t-primitive-type* control-stack-sc-number n)))
;;; Make a passing location TN for a local call return PC.
(!def-vm-support-routine make-return-pc-passing-location (standard)
(declare (ignore standard))
(make-wired-tn (primitive-type-or-lose 'system-area-pointer)
- sap-stack-sc-number return-pc-save-offset))
+ sap-stack-sc-number return-pc-save-offset))
;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a
;;; location to pass OLD-FP in.
(!def-vm-support-routine make-old-fp-passing-location (standard)
(declare (ignore standard))
(make-wired-tn *fixnum-primitive-type* control-stack-sc-number
- ocfp-save-offset))
+ ocfp-save-offset))
;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current
;;; function. We treat these specially so that the debugger can find
;;; them at a known location.
;;;
;;; Without using a save-tn - which does not make much sense if it is
-;;; wired to the stack?
+;;; wired to the stack?
(!def-vm-support-routine make-old-fp-save-location (physenv)
(physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type*
- control-stack-sc-number
- ocfp-save-offset)
- physenv))
+ control-stack-sc-number
+ ocfp-save-offset)
+ physenv))
(!def-vm-support-routine make-return-pc-save-location (physenv)
(physenv-debug-live-tn
(make-wired-tn (primitive-type-or-lose 'system-area-pointer)
- sap-stack-sc-number return-pc-save-offset)
+ sap-stack-sc-number return-pc-save-offset)
physenv))
;;; Make a TN for the standard argument count passing location. We only
;;; continuation within a function.
(!def-vm-support-routine make-unknown-values-locations ()
(list (make-stack-pointer-tn)
- (make-normal-tn *fixnum-primitive-type*)))
+ (make-normal-tn *fixnum-primitive-type*)))
;;; This function is called by the ENTRY-ANALYZE phase, allowing
;;; VM-dependent initialization of the IR2-COMPONENT structure. We
;; we'll just live with this ugliness. -- WHN 2002-01-02
(dotimes (i (1+ code-constants-offset))
(vector-push-extend nil
- (ir2-component-constants (component-info component))))
+ (ir2-component-constants (component-info component))))
(values))
\f
;;;; frame hackery
(inst simple-fun-header-word)
(dotimes (i (* n-word-bytes (1- simple-fun-code-offset)))
(inst byte 0))
-
+
;; The start of the actual code.
;; Save the return-pc.
(popw rbp-tn (- (1+ return-pc-save-offset)))
(unless copy-more-arg-follows
;; The args fit within the frame so just allocate the frame.
(inst lea rsp-tn
- (make-ea :qword :base rbp-tn
- :disp (- (* n-word-bytes
- (max 3 (sb-allocated-size 'stack)))))))
+ (make-ea :qword :base rbp-tn
+ :disp (- (* n-word-bytes
+ (max 3 (sb-allocated-size 'stack)))))))
(trace-table-entry trace-table-normal)))
;;; callee (who has the same size stack as us).
(define-vop (allocate-frame)
(:results (res :scs (any-reg control-stack))
- (nfp))
+ (nfp))
(:info callee)
(:ignore nfp callee)
(:generator 2
;;; returned, regardless of the number of values desired.
(defun default-unknown-values (vop values nvals)
(declare (type (or tn-ref null) values)
- (type unsigned-byte nvals))
+ (type unsigned-byte nvals))
(cond
((<= nvals 1)
(note-this-location vop :single-value-return)
(inst jmp-short regs-defaulted)
;; Default the unsupplied registers.
(let* ((2nd-tn-ref (tn-ref-across values))
- (2nd-tn (tn-ref-tn 2nd-tn-ref)))
- (inst mov 2nd-tn nil-value)
- (when (> nvals 2)
- (loop
- for tn-ref = (tn-ref-across 2nd-tn-ref)
- then (tn-ref-across tn-ref)
- for count from 2 below register-arg-count
- do (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
+ (2nd-tn (tn-ref-tn 2nd-tn-ref)))
+ (inst mov 2nd-tn nil-value)
+ (when (> nvals 2)
+ (loop
+ for tn-ref = (tn-ref-across 2nd-tn-ref)
+ then (tn-ref-across tn-ref)
+ for count from 2 below register-arg-count
+ do (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
(inst mov rbx-tn rsp-tn)
(emit-label regs-defaulted)
(inst mov rsp-tn rbx-tn)))
;; NVALS=6 that is 73/89 bytes, and for NVALS=7 that is 87/107
;; bytes which is likely better than using the blt below.
(let ((regs-defaulted (gen-label))
- (defaulting-done (gen-label))
- (default-stack-slots (gen-label)))
+ (defaulting-done (gen-label))
+ (default-stack-slots (gen-label)))
(note-this-location vop :unknown-return)
;; Branch off to the MV case.
(inst nop)
;; Default the register args
(inst mov rax-tn nil-value)
(do ((i 1 (1+ i))
- (val (tn-ref-across values) (tn-ref-across val)))
- ((= i (min nvals register-arg-count)))
- (inst mov (tn-ref-tn val) rax-tn))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i (min nvals register-arg-count)))
+ (inst mov (tn-ref-tn val) rax-tn))
;; Fake other registers so it looks like we returned with all the
;; registers filled in.
(inst mov rax-tn nil-value)
(storew rdx-tn rbx-tn -1)
(collect ((defaults))
- (do ((i register-arg-count (1+ i))
- (val (do ((i 0 (1+ i))
- (val values (tn-ref-across val)))
- ((= i register-arg-count) val))
- (tn-ref-across val)))
- ((null val))
- (let ((default-lab (gen-label))
- (tn (tn-ref-tn val)))
- (defaults (cons default-lab tn))
-
- (inst cmp rcx-tn (fixnumize i))
- (inst jmp :be default-lab)
- (loadw rdx-tn rbx-tn (- (1+ i)))
- (inst mov tn rdx-tn)))
-
- (emit-label defaulting-done)
- (loadw rdx-tn rbx-tn -1)
- (move rsp-tn rbx-tn)
-
- (let ((defaults (defaults)))
- (when defaults
- (assemble (*elsewhere*)
- (trace-table-entry trace-table-fun-prologue)
- (emit-label default-stack-slots)
- (dolist (default defaults)
- (emit-label (car default))
- (inst mov (cdr default) rax-tn))
- (inst jmp defaulting-done)
- (trace-table-entry trace-table-normal)))))))
+ (do ((i register-arg-count (1+ i))
+ (val (do ((i 0 (1+ i))
+ (val values (tn-ref-across val)))
+ ((= i register-arg-count) val))
+ (tn-ref-across val)))
+ ((null val))
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn val)))
+ (defaults (cons default-lab tn))
+
+ (inst cmp rcx-tn (fixnumize i))
+ (inst jmp :be default-lab)
+ (loadw rdx-tn rbx-tn (- (1+ i)))
+ (inst mov tn rdx-tn)))
+
+ (emit-label defaulting-done)
+ (loadw rdx-tn rbx-tn -1)
+ (move rsp-tn rbx-tn)
+
+ (let ((defaults (defaults)))
+ (when defaults
+ (assemble (*elsewhere*)
+ (trace-table-entry trace-table-fun-prologue)
+ (emit-label default-stack-slots)
+ (dolist (default defaults)
+ (emit-label (car default))
+ (inst mov (cdr default) rax-tn))
+ (inst jmp defaulting-done)
+ (trace-table-entry trace-table-normal)))))))
(t
(let ((regs-defaulted (gen-label))
- (restore-edi (gen-label))
- (no-stack-args (gen-label))
- (default-stack-vals (gen-label))
- (count-okay (gen-label)))
+ (restore-edi (gen-label))
+ (no-stack-args (gen-label))
+ (default-stack-vals (gen-label))
+ (count-okay (gen-label)))
(note-this-location vop :unknown-return)
;; Branch off to the MV case.
(inst nop)
;; Compute a pointer to where to put the [defaulted] stack values.
(emit-label no-stack-args)
(inst lea rdi-tn
- (make-ea :qword :base rbp-tn
- :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+ (make-ea :qword :base rbp-tn
+ :disp (* (- (1+ register-arg-count)) n-word-bytes)))
;; Load RAX with NIL so we can quickly store it, and set up
;; stuff for the loop.
(inst mov rax-tn nil-value)
(inst mov rax-tn rcx-tn)
;; Compute a pointer to where the stack args go.
(inst lea rdi-tn
- (make-ea :qword :base rbp-tn
- :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+ (make-ea :qword :base rbp-tn
+ :disp (* (- (1+ register-arg-count)) n-word-bytes)))
;; Save ESI, and compute a pointer to where the args come from.
(storew rsi-tn rbx-tn (- (1+ 2)))
(inst lea rsi-tn
- (make-ea :qword :base rbx-tn
- :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+ (make-ea :qword :base rbx-tn
+ :disp (* (- (1+ register-arg-count)) n-word-bytes)))
;; Do the copy.
- (inst shr rcx-tn word-shift) ; make word count
+ (inst shr rcx-tn word-shift) ; make word count
(inst std)
(inst rep)
(inst movs :qword)
;; If none, then just blow out of here.
(inst jmp :le restore-edi)
(inst mov rcx-tn rax-tn)
- (inst shr rcx-tn word-shift) ; word count
+ (inst shr rcx-tn word-shift) ; word count
;; Load RAX with NIL for fast storing.
(inst mov rax-tn nil-value)
;; Do the store.
(defun receive-unknown-values (args nargs start count)
(declare (type tn args nargs start count))
(let ((variable-values (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst nop)
(inst jmp-short variable-values)
;;; handles is allocation of the result temporaries.
(define-vop (unknown-values-receiver)
(:temporary (:sc descriptor-reg :offset rbx-offset
- :from :eval :to (:result 0))
- values-start)
+ :from :eval :to (:result 0))
+ values-start)
(:temporary (:sc any-reg :offset rcx-offset
- :from :eval :to (:result 1))
- nvals)
+ :from :eval :to (:result 1))
+ nvals)
(:results (start :scs (any-reg control-stack))
- (count :scs (any-reg control-stack))))
+ (count :scs (any-reg control-stack))))
\f
;;;; local call with unknown values convention return
;;; function.
(define-vop (call-local)
(:args (fp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:temporary (:sc unsigned-reg) return-label)
(:results (values :more t))
(:save-p t)
(let ((ret-tn (callee-return-pc-tn callee)))
#+nil
(format t "*call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
- ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
- (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
+ ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
+ (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
;; Is the return-pc on the stack or in a register?
(sc-case ret-tn
- ((sap-stack)
- #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
- (tn-offset ret-tn))
- (inst lea return-label (make-fixup nil :code-object RETURN))
- (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
- ((sap-reg)
- (inst lea ret-tn (make-fixup nil :code-object RETURN)))))
+ ((sap-stack)
+ #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
+ (tn-offset ret-tn))
+ (inst lea return-label (make-fixup nil :code-object RETURN))
+ (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
+ ((sap-reg)
+ (inst lea ret-tn (make-fixup nil :code-object RETURN)))))
(note-this-location vop :call-site)
(inst jmp target)
;;; glob and the number of values received.
(define-vop (multiple-call-local unknown-values-receiver)
(:args (fp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:temporary (:sc unsigned-reg) return-label)
(:save-p t)
(:move-args :local-call)
(let ((ret-tn (callee-return-pc-tn callee)))
#+nil
(format t "*multiple-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
- ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
- (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
+ ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
+ (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
;; Is the return-pc on the stack or in a register?
(sc-case ret-tn
- ((sap-stack)
- #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
- (tn-offset ret-tn))
- ;; Stack
- (inst lea return-label (make-fixup nil :code-object RETURN))
- (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
- ((sap-reg)
- ;; Register
- (inst lea ret-tn (make-fixup nil :code-object RETURN)))))
+ ((sap-stack)
+ #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
+ (tn-offset ret-tn))
+ ;; Stack
+ (inst lea return-label (make-fixup nil :code-object RETURN))
+ (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
+ ((sap-reg)
+ ;; Register
+ (inst lea ret-tn (make-fixup nil :code-object RETURN)))))
(note-this-location vop :call-site)
(inst jmp target)
;;; we use MAYBE-LOAD-STACK-TN.
(define-vop (known-call-local)
(:args (fp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:temporary (:sc unsigned-reg) return-label)
(:results (res :more t))
(:move-args :local-call)
#+nil
(format t "*known-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
- ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
- (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
+ ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
+ (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
;; Is the return-pc on the stack or in a register?
(sc-case ret-tn
- ((sap-stack)
- #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
- (tn-offset ret-tn))
- ;; Stack
- (inst lea return-label (make-fixup nil :code-object RETURN))
- (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
- ((sap-reg)
- ;; Register
- (inst lea ret-tn (make-fixup nil :code-object RETURN)))))
+ ((sap-stack)
+ #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
+ (tn-offset ret-tn))
+ ;; Stack
+ (inst lea return-label (make-fixup nil :code-object RETURN))
+ (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
+ ((sap-reg)
+ ;; Register
+ (inst lea ret-tn (make-fixup nil :code-object RETURN)))))
(note-this-location vop :call-site)
(inst jmp target)
#+nil
(define-vop (known-return)
(:args (old-fp)
- (return-pc :scs (any-reg immediate-stack) :target rpc)
- (vals :more t))
+ (return-pc :scs (any-reg immediate-stack) :target rpc)
+ (vals :more t))
(:move-args :known-return)
(:info val-locs)
(:temporary (:sc unsigned-reg :from (:argument 1)) rpc)
;;; The return-pc may be in a register or on the stack in any slot.
(define-vop (known-return)
(:args (old-fp)
- (return-pc)
- (vals :more t))
+ (return-pc)
+ (vals :more t))
(:move-args :known-return)
(:info val-locs)
(:ignore val-locs vals)
(sc-case return-pc
((sap-reg)
(sc-case old-fp
- ((control-stack)
- (cond ((zerop (tn-offset old-fp))
- ;; Zot all of the stack except for the old-fp.
- (inst lea rsp-tn (make-ea :qword :base rbp-tn
- :disp (- (* (1+ ocfp-save-offset)
- n-word-bytes))))
- ;; Restore the old fp from its save location on the stack,
- ;; and zot the stack.
- (inst pop rbp-tn))
-
- (t
- (cerror "Continue anyway"
- "VOP return-local doesn't work if old-fp (in slot ~
+ ((control-stack)
+ (cond ((zerop (tn-offset old-fp))
+ ;; Zot all of the stack except for the old-fp.
+ (inst lea rsp-tn (make-ea :qword :base rbp-tn
+ :disp (- (* (1+ ocfp-save-offset)
+ n-word-bytes))))
+ ;; Restore the old fp from its save location on the stack,
+ ;; and zot the stack.
+ (inst pop rbp-tn))
+
+ (t
+ (cerror "Continue anyway"
+ "VOP return-local doesn't work if old-fp (in slot ~
~S) is not in slot 0"
- (tn-offset old-fp)))))
+ (tn-offset old-fp)))))
- ((any-reg descriptor-reg)
- ;; Zot all the stack.
- (move rsp-tn rbp-tn)
- ;; Restore the old-fp.
- (move rbp-tn old-fp)))
+ ((any-reg descriptor-reg)
+ ;; Zot all the stack.
+ (move rsp-tn rbp-tn)
+ ;; Restore the old-fp.
+ (move rbp-tn old-fp)))
;; Return; return-pc is in a register.
(inst jmp return-pc))
((sap-stack)
(inst lea rsp-tn
- (make-ea :qword :base rbp-tn
- :disp (- (* (1+ (tn-offset return-pc)) n-word-bytes))))
+ (make-ea :qword :base rbp-tn
+ :disp (- (* (1+ (tn-offset return-pc)) n-word-bytes))))
(move rbp-tn old-fp)
(inst ret (* (tn-offset return-pc) n-word-bytes))))
;;; passed as a more arg, but there is no new-FP, since the arguments
;;; have been set up in the current frame.
(macrolet ((define-full-call (name named return variable)
- (aver (not (and variable (eq return :tail))))
- `(define-vop (,name
- ,@(when (eq return :unknown)
- '(unknown-values-receiver)))
- (:args
- ,@(unless (eq return :tail)
- '((new-fp :scs (any-reg) :to (:argument 1))))
-
- (fun :scs (descriptor-reg control-stack)
- :target rax :to (:argument 0))
-
- ,@(when (eq return :tail)
- '((old-fp)
- (return-pc)))
-
- ,@(unless variable '((args :more t :scs (descriptor-reg)))))
-
- ,@(when (eq return :fixed)
- '((:results (values :more t))))
-
- (:save-p ,(if (eq return :tail) :compute-only t))
-
- ,@(unless (or (eq return :tail) variable)
- '((:move-args :full-call)))
-
- (:vop-var vop)
- (:info
- ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
-
- (:ignore
- ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(args)))
-
- ;; We pass either the fdefn object (for named call) or
- ;; the actual function object (for unnamed call) in
- ;; RAX. With named call, closure-tramp will replace it
- ;; with the real function and invoke the real function
- ;; for closures. Non-closures do not need this value,
- ;; so don't care what shows up in it.
- (:temporary
- (:sc descriptor-reg
- :offset rax-offset
- :from (:argument 0)
- :to :eval)
- rax)
-
- ;; We pass the number of arguments in RCX.
- (:temporary (:sc unsigned-reg :offset rcx-offset :to :eval) rcx)
-
- ;; With variable call, we have to load the
- ;; register-args out of the (new) stack frame before
- ;; doing the call. Therefore, we have to tell the
- ;; lifetime stuff that we need to use them.
- ,@(when variable
- (mapcar (lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :from (:argument 0)
- :to :eval)
- ,name))
- *register-arg-names* *register-arg-offsets*))
-
- ,@(when (eq return :tail)
- '((:temporary (:sc unsigned-reg
- :from (:argument 1)
- :to (:argument 2))
- old-fp-tmp)))
-
- (:generator ,(+ (if named 5 0)
- (if variable 19 1)
- (if (eq return :tail) 0 10)
- 15
- (if (eq return :unknown) 25 0))
- (trace-table-entry trace-table-call-site)
-
- ;; This has to be done before the frame pointer is
- ;; changed! RAX stores the 'lexical environment' needed
- ;; for closures.
- (move rax fun)
-
-
- ,@(if variable
- ;; For variable call, compute the number of
- ;; arguments and move some of the arguments to
- ;; registers.
- (collect ((noise))
- ;; Compute the number of arguments.
- (noise '(inst mov rcx new-fp))
- (noise '(inst sub rcx rsp-tn))
- ;; Move the necessary args to registers,
- ;; this moves them all even if they are
- ;; not all needed.
- (loop
- for name in *register-arg-names*
- for index downfrom -1
- do (noise `(loadw ,name new-fp ,index)))
- (noise))
- '((if (zerop nargs)
- (inst xor rcx rcx)
- (inst mov rcx (fixnumize nargs)))))
- ,@(cond ((eq return :tail)
- '(;; Python has figured out what frame we should
- ;; return to so might as well use that clue.
- ;; This seems really important to the
- ;; implementation of things like
- ;; (without-interrupts ...)
- ;;
- ;; dtc; Could be doing a tail call from a
- ;; known-local-call etc in which the old-fp
- ;; or ret-pc are in regs or in non-standard
- ;; places. If the passing location were
- ;; wired to the stack in standard locations
- ;; then these moves will be un-necessary;
- ;; this is probably best for the x86.
- (sc-case old-fp
- ((control-stack)
- (unless (= ocfp-save-offset
- (tn-offset old-fp))
- ;; FIXME: FORMAT T for stale
- ;; diagnostic output (several of
- ;; them around here), ick
- (format t "** tail-call old-fp not S0~%")
- (move old-fp-tmp old-fp)
- (storew old-fp-tmp
- rbp-tn
- (- (1+ ocfp-save-offset)))))
- ((any-reg descriptor-reg)
- (format t "** tail-call old-fp in reg not S0~%")
- (storew old-fp
- rbp-tn
- (- (1+ ocfp-save-offset)))))
-
- ;; For tail call, we have to push the
- ;; return-pc so that it looks like we CALLed
- ;; drspite the fact that we are going to JMP.
- (inst push return-pc)
- ))
- (t
- ;; For non-tail call, we have to save our
- ;; frame pointer and install the new frame
- ;; pointer. We can't load stack tns after this
- ;; point.
- `(;; Python doesn't seem to allocate a frame
- ;; here which doesn't leave room for the
- ;; ofp/ret stuff.
-
- ;; The variable args are on the stack and
- ;; become the frame, but there may be <3
- ;; args and 3 stack slots are assumed
- ;; allocate on the call. So need to ensure
- ;; there are at least 3 slots. This hack
- ;; just adds 3 more.
- ,(if variable
- '(inst sub rsp-tn (fixnumize 3)))
-
- ;; Save the fp
- (storew rbp-tn new-fp (- (1+ ocfp-save-offset)))
-
- (move rbp-tn new-fp) ; NB - now on new stack frame.
- )))
-
- (note-this-location vop :call-site)
-
- (inst ,(if (eq return :tail) 'jmp 'call)
- (make-ea :qword :base rax
- :disp ,(if named
- '(- (* fdefn-raw-addr-slot
- n-word-bytes)
- other-pointer-lowtag)
- '(- (* closure-fun-slot n-word-bytes)
- fun-pointer-lowtag))))
- ,@(ecase return
- (:fixed
- '((default-unknown-values vop values nvals)))
- (:unknown
- '((note-this-location vop :unknown-return)
- (receive-unknown-values values-start nvals start count)))
- (:tail))
- (trace-table-entry trace-table-normal)))))
+ (aver (not (and variable (eq return :tail))))
+ `(define-vop (,name
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
+ (:args
+ ,@(unless (eq return :tail)
+ '((new-fp :scs (any-reg) :to (:argument 1))))
+
+ (fun :scs (descriptor-reg control-stack)
+ :target rax :to (:argument 0))
+
+ ,@(when (eq return :tail)
+ '((old-fp)
+ (return-pc)))
+
+ ,@(unless variable '((args :more t :scs (descriptor-reg)))))
+
+ ,@(when (eq return :fixed)
+ '((:results (values :more t))))
+
+ (:save-p ,(if (eq return :tail) :compute-only t))
+
+ ,@(unless (or (eq return :tail) variable)
+ '((:move-args :full-call)))
+
+ (:vop-var vop)
+ (:info
+ ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(nargs))
+ ,@(when (eq return :fixed) '(nvals)))
+
+ (:ignore
+ ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(args)))
+
+ ;; We pass either the fdefn object (for named call) or
+ ;; the actual function object (for unnamed call) in
+ ;; RAX. With named call, closure-tramp will replace it
+ ;; with the real function and invoke the real function
+ ;; for closures. Non-closures do not need this value,
+ ;; so don't care what shows up in it.
+ (:temporary
+ (:sc descriptor-reg
+ :offset rax-offset
+ :from (:argument 0)
+ :to :eval)
+ rax)
+
+ ;; We pass the number of arguments in RCX.
+ (:temporary (:sc unsigned-reg :offset rcx-offset :to :eval) rcx)
+
+ ;; With variable call, we have to load the
+ ;; register-args out of the (new) stack frame before
+ ;; doing the call. Therefore, we have to tell the
+ ;; lifetime stuff that we need to use them.
+ ,@(when variable
+ (mapcar (lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :from (:argument 0)
+ :to :eval)
+ ,name))
+ *register-arg-names* *register-arg-offsets*))
+
+ ,@(when (eq return :tail)
+ '((:temporary (:sc unsigned-reg
+ :from (:argument 1)
+ :to (:argument 2))
+ old-fp-tmp)))
+
+ (:generator ,(+ (if named 5 0)
+ (if variable 19 1)
+ (if (eq return :tail) 0 10)
+ 15
+ (if (eq return :unknown) 25 0))
+ (trace-table-entry trace-table-call-site)
+
+ ;; This has to be done before the frame pointer is
+ ;; changed! RAX stores the 'lexical environment' needed
+ ;; for closures.
+ (move rax fun)
+
+
+ ,@(if variable
+ ;; For variable call, compute the number of
+ ;; arguments and move some of the arguments to
+ ;; registers.
+ (collect ((noise))
+ ;; Compute the number of arguments.
+ (noise '(inst mov rcx new-fp))
+ (noise '(inst sub rcx rsp-tn))
+ ;; Move the necessary args to registers,
+ ;; this moves them all even if they are
+ ;; not all needed.
+ (loop
+ for name in *register-arg-names*
+ for index downfrom -1
+ do (noise `(loadw ,name new-fp ,index)))
+ (noise))
+ '((if (zerop nargs)
+ (inst xor rcx rcx)
+ (inst mov rcx (fixnumize nargs)))))
+ ,@(cond ((eq return :tail)
+ '(;; Python has figured out what frame we should
+ ;; return to so might as well use that clue.
+ ;; This seems really important to the
+ ;; implementation of things like
+ ;; (without-interrupts ...)
+ ;;
+ ;; dtc; Could be doing a tail call from a
+ ;; known-local-call etc in which the old-fp
+ ;; or ret-pc are in regs or in non-standard
+ ;; places. If the passing location were
+ ;; wired to the stack in standard locations
+ ;; then these moves will be un-necessary;
+ ;; this is probably best for the x86.
+ (sc-case old-fp
+ ((control-stack)
+ (unless (= ocfp-save-offset
+ (tn-offset old-fp))
+ ;; FIXME: FORMAT T for stale
+ ;; diagnostic output (several of
+ ;; them around here), ick
+ (format t "** tail-call old-fp not S0~%")
+ (move old-fp-tmp old-fp)
+ (storew old-fp-tmp
+ rbp-tn
+ (- (1+ ocfp-save-offset)))))
+ ((any-reg descriptor-reg)
+ (format t "** tail-call old-fp in reg not S0~%")
+ (storew old-fp
+ rbp-tn
+ (- (1+ ocfp-save-offset)))))
+
+ ;; For tail call, we have to push the
+ ;; return-pc so that it looks like we CALLed
+ ;; drspite the fact that we are going to JMP.
+ (inst push return-pc)
+ ))
+ (t
+ ;; For non-tail call, we have to save our
+ ;; frame pointer and install the new frame
+ ;; pointer. We can't load stack tns after this
+ ;; point.
+ `(;; Python doesn't seem to allocate a frame
+ ;; here which doesn't leave room for the
+ ;; ofp/ret stuff.
+
+ ;; The variable args are on the stack and
+ ;; become the frame, but there may be <3
+ ;; args and 3 stack slots are assumed
+ ;; allocate on the call. So need to ensure
+ ;; there are at least 3 slots. This hack
+ ;; just adds 3 more.
+ ,(if variable
+ '(inst sub rsp-tn (fixnumize 3)))
+
+ ;; Save the fp
+ (storew rbp-tn new-fp (- (1+ ocfp-save-offset)))
+
+ (move rbp-tn new-fp) ; NB - now on new stack frame.
+ )))
+
+ (note-this-location vop :call-site)
+
+ (inst ,(if (eq return :tail) 'jmp 'call)
+ (make-ea :qword :base rax
+ :disp ,(if named
+ '(- (* fdefn-raw-addr-slot
+ n-word-bytes)
+ other-pointer-lowtag)
+ '(- (* closure-fun-slot n-word-bytes)
+ fun-pointer-lowtag))))
+ ,@(ecase return
+ (:fixed
+ '((default-unknown-values vop values nvals)))
+ (:unknown
+ '((note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count)))
+ (:tail))
+ (trace-table-entry trace-table-normal)))))
(define-full-call call nil :fixed nil)
(define-full-call call-named t :fixed nil)
;;; routine. We just set things up so that it can find what it needs.
(define-vop (tail-call-variable)
(:args (args :scs (any-reg control-stack) :target rsi)
- (function :scs (descriptor-reg control-stack) :target rax)
- (old-fp)
- (ret-addr))
+ (function :scs (descriptor-reg control-stack) :target rax)
+ (old-fp)
+ (ret-addr))
(:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) rsi)
(:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
(:temporary (:sc unsigned-reg) call-target)
;; The following assumes that the return-pc and old-fp are on the
;; stack in their standard save locations - Check this.
(unless (and (sc-is old-fp control-stack)
- (= (tn-offset old-fp) ocfp-save-offset))
- (error "tail-call-variable: ocfp not on stack in standard save location?"))
+ (= (tn-offset old-fp) ocfp-save-offset))
+ (error "tail-call-variable: ocfp not on stack in standard save location?"))
(unless (and (sc-is ret-addr sap-stack)
- (= (tn-offset ret-addr) return-pc-save-offset))
- (error "tail-call-variable: ret-addr not on stack in standard save location?"))
+ (= (tn-offset ret-addr) return-pc-save-offset))
+ (error "tail-call-variable: ret-addr not on stack in standard save location?"))
(inst lea call-target
- (make-ea :qword
- :disp (make-fixup 'tail-call-variable :assembly-routine)))
+ (make-ea :qword
+ :disp (make-fixup 'tail-call-variable :assembly-routine)))
;; And jump to the assembly routine.
(inst jmp call-target)))
\f
;;; having problems targeting args to regs -- using temps instead.
(define-vop (return-single)
(:args (old-fp)
- (return-pc)
- (value))
+ (return-pc)
+ (value))
(:temporary (:sc unsigned-reg) ofp)
(:temporary (:sc unsigned-reg) ret)
(:ignore value)
;;; the values, and jump directly to return-pc.
(define-vop (return)
(:args (old-fp)
- (return-pc :to (:eval 1))
- (values :more t))
+ (return-pc :to (:eval 1))
+ (values :more t))
(:ignore values)
(:info nvals)
;; registers so that we can default the argument registers without
;; trashing return-pc.
(:temporary (:sc unsigned-reg :offset (first *register-arg-offsets*)
- :from :eval) a0)
+ :from :eval) a0)
(:temporary (:sc unsigned-reg :offset (second *register-arg-offsets*)
- :from :eval) a1)
+ :from :eval) a1)
(:temporary (:sc unsigned-reg :offset (third *register-arg-offsets*)
- :from :eval) a2)
+ :from :eval) a2)
(:generator 6
(trace-table-entry trace-table-fun-epilogue)
;; Establish the values pointer and values count.
(move rbx rbp-tn)
(if (zerop nvals)
- (inst xor rcx rcx) ; smaller
+ (inst xor rcx rcx) ; smaller
(inst mov rcx (fixnumize nvals)))
;; Restore the frame pointer.
(move rbp-tn old-fp)
;; Clear as much of the stack as possible, but not past the return
;; address.
(inst lea rsp-tn (make-ea :qword :base rbx
- :disp (- (* (max nvals 2) n-word-bytes))))
+ :disp (- (* (max nvals 2) n-word-bytes))))
;; Pre-default any argument register that need it.
(when (< nvals register-arg-count)
(let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
- (first (first arg-tns)))
- (inst mov first nil-value)
- (dolist (tn (cdr arg-tns))
- (inst mov tn first))))
+ (first (first arg-tns)))
+ (inst mov first nil-value)
+ (dolist (tn (cdr arg-tns))
+ (inst mov tn first))))
;; And away we go. Except that return-pc is still on the
;; stack and we've changed the stack pointer. So we have to
;; tell it to index off of RBX instead of RBP.
(cond ((zerop nvals)
- ;; Return popping the return address and the OCFP.
- (inst ret n-word-bytes))
- ((= nvals 1)
- ;; Return popping the return, leaving 1 slot. Can this
- ;; happen, or is a single value return handled elsewhere?
- (inst ret))
- (t
- (inst jmp (make-ea :qword :base rbx
- :disp (- (* (1+ (tn-offset return-pc))
- n-word-bytes))))))
+ ;; Return popping the return address and the OCFP.
+ (inst ret n-word-bytes))
+ ((= nvals 1)
+ ;; Return popping the return, leaving 1 slot. Can this
+ ;; happen, or is a single value return handled elsewhere?
+ (inst ret))
+ (t
+ (inst jmp (make-ea :qword :base rbx
+ :disp (- (* (1+ (tn-offset return-pc))
+ n-word-bytes))))))
(trace-table-entry trace-table-normal)))
;;; RSI -- pointer to where to find the values.
(define-vop (return-multiple)
(:args (old-fp :to (:eval 1) :target old-fp-temp)
- (return-pc :target rax)
- (vals :scs (any-reg) :target rsi)
- (nvals :scs (any-reg) :target rcx))
+ (return-pc :target rax)
+ (vals :scs (any-reg) :target rsi)
+ (nvals :scs (any-reg) :target rcx))
(:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
(:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 2)) rsi)
(:temporary (:sc unsigned-reg :offset rbx-offset :from (:eval 0)) rbx)
(:temporary (:sc unsigned-reg) return-asm)
(:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*)
- :from (:eval 0)) a0)
+ :from (:eval 0)) a0)
(:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp)
(:node-var node)
(unless (policy node (> space speed))
;; Check for the single case.
(let ((not-single (gen-label)))
- (inst cmp nvals (fixnumize 1))
- (inst jmp :ne not-single)
-
- ;; Return with one value.
- (loadw a0 vals -1)
- ;; Clear the stack. We load old-fp into a register before clearing
- ;; the stack.
- (move old-fp-temp old-fp)
- (move rsp-tn rbp-tn)
- (move rbp-tn old-fp-temp)
- ;; Fix the return-pc to point at the single-value entry point.
- (inst add rax 3) ; skip "mov %rbx,%rsp" insn in caller
- ;; Out of here.
- (inst jmp rax)
-
- ;; Nope, not the single case. Jump to the assembly routine.
- (emit-label not-single)))
+ (inst cmp nvals (fixnumize 1))
+ (inst jmp :ne not-single)
+
+ ;; Return with one value.
+ (loadw a0 vals -1)
+ ;; Clear the stack. We load old-fp into a register before clearing
+ ;; the stack.
+ (move old-fp-temp old-fp)
+ (move rsp-tn rbp-tn)
+ (move rbp-tn old-fp-temp)
+ ;; Fix the return-pc to point at the single-value entry point.
+ (inst add rax 3) ; skip "mov %rbx,%rsp" insn in caller
+ ;; Out of here.
+ (inst jmp rax)
+
+ ;; Nope, not the single case. Jump to the assembly routine.
+ (emit-label not-single)))
(move rsi vals)
(move rcx nvals)
(move rbx rbp-tn)
(move rbp-tn old-fp)
(inst lea return-asm
- (make-ea :qword :disp (make-fixup 'return-multiple
- :assembly-routine)))
+ (make-ea :qword :disp (make-fixup 'return-multiple
+ :assembly-routine)))
(inst jmp return-asm)
(trace-table-entry trace-table-normal)))
\f
(:generator 20
;; Avoid the copy if there are no more args.
(cond ((zerop fixed)
- (inst jecxz JUST-ALLOC-FRAME))
- (t
- (inst cmp rcx-tn (fixnumize fixed))
- (inst jmp :be JUST-ALLOC-FRAME)))
+ (inst jecxz JUST-ALLOC-FRAME))
+ (t
+ (inst cmp rcx-tn (fixnumize fixed))
+ (inst jmp :be JUST-ALLOC-FRAME)))
;; Allocate the space on the stack.
;; stack = rbp - (max 3 frame-size) - (nargs - fixed)
(inst lea rbx-tn
- (make-ea :qword :base rbp-tn
- :disp (- (fixnumize fixed)
- (* n-word-bytes
- (max 3 (sb-allocated-size 'stack))))))
+ (make-ea :qword :base rbp-tn
+ :disp (- (fixnumize fixed)
+ (* n-word-bytes
+ (max 3 (sb-allocated-size 'stack))))))
(inst sub rbx-tn rcx-tn) ; Got the new stack in rbx
(inst mov rsp-tn rbx-tn)
(inst mov rbx-tn rcx-tn)
(cond ((< fixed register-arg-count)
- ;; We must stop when we run out of stack args, not when we
- ;; run out of more args.
- ;; Number to copy = nargs-3
- (inst sub rcx-tn (fixnumize register-arg-count))
- ;; Everything of interest in registers.
- (inst jmp :be DO-REGS))
- (t
- ;; Number to copy = nargs-fixed
- (inst sub rcx-tn (fixnumize fixed))))
+ ;; We must stop when we run out of stack args, not when we
+ ;; run out of more args.
+ ;; Number to copy = nargs-3
+ (inst sub rcx-tn (fixnumize register-arg-count))
+ ;; Everything of interest in registers.
+ (inst jmp :be DO-REGS))
+ (t
+ ;; Number to copy = nargs-fixed
+ (inst sub rcx-tn (fixnumize fixed))))
;; Save rdi and rsi register args.
(inst push rdi-tn)
(inst mov rsi-tn rbp-tn)
(inst sub rsi-tn rbx-tn)
- (inst shr rcx-tn word-shift) ; make word count
+ (inst shr rcx-tn word-shift) ; make word count
;; And copy the args.
- (inst cld) ; auto-inc RSI and RDI.
+ (inst cld) ; auto-inc RSI and RDI.
(inst rep)
(inst movs :qword)
;; Here: nargs>=1 && nargs>fixed
(when (< fixed register-arg-count)
- ;; Now we have to deposit any more args that showed up in
- ;; registers.
- (do ((i fixed))
- ( nil )
- ;; Store it relative to rbp
- (inst mov (make-ea :qword :base rbp-tn
- :disp (- (* n-word-bytes
- (+ 1 (- i fixed)
- (max 3 (sb-allocated-size 'stack))))))
- (nth i *register-arg-tns*))
-
- (incf i)
- (when (>= i register-arg-count)
- (return))
-
- ;; Don't deposit any more than there are.
- (if (zerop i)
- (inst test rcx-tn rcx-tn)
- (inst cmp rcx-tn (fixnumize i)))
- (inst jmp :eq DONE)))
+ ;; Now we have to deposit any more args that showed up in
+ ;; registers.
+ (do ((i fixed))
+ ( nil )
+ ;; Store it relative to rbp
+ (inst mov (make-ea :qword :base rbp-tn
+ :disp (- (* n-word-bytes
+ (+ 1 (- i fixed)
+ (max 3 (sb-allocated-size 'stack))))))
+ (nth i *register-arg-tns*))
+
+ (incf i)
+ (when (>= i register-arg-count)
+ (return))
+
+ ;; Don't deposit any more than there are.
+ (if (zerop i)
+ (inst test rcx-tn rcx-tn)
+ (inst cmp rcx-tn (fixnumize i)))
+ (inst jmp :eq DONE)))
(inst jmp DONE)
JUST-ALLOC-FRAME
(inst lea rsp-tn
- (make-ea :qword :base rbp-tn
- :disp (- (* n-word-bytes
- (max 3 (sb-allocated-size 'stack))))))
+ (make-ea :qword :base rbp-tn
+ :disp (- (* n-word-bytes
+ (max 3 (sb-allocated-size 'stack))))))
DONE))
(:translate %more-arg)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg) :target temp))
+ (index :scs (any-reg) :target temp))
(:arg-types * tagged-num)
(:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
(:results (value :scs (any-reg descriptor-reg)))
(:result-types *)
(:generator 4
(inst mov value
- (make-ea :qword :base object :disp (- (* index n-word-bytes))))))
+ (make-ea :qword :base object :disp (- (* index n-word-bytes))))))
;;; Turn more arg (context, count) into a list.
(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args))
(:translate %listify-rest-args)
(:policy :safe)
(:args (context :scs (descriptor-reg) :target src)
- (count :scs (any-reg) :target rcx))
+ (count :scs (any-reg) :target rcx))
(:arg-types * tagged-num)
(:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) src)
(:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
(:node-var node)
(:generator 20
(let ((enter (gen-label))
- (loop (gen-label))
- (done (gen-label))
- (stack-allocate-p (node-stack-allocate-p node)))
+ (loop (gen-label))
+ (done (gen-label))
+ (stack-allocate-p (node-stack-allocate-p node)))
(move src context)
(move rcx count)
;; Check to see whether there are no args, and just return NIL if so.
(:arg-types positive-fixnum (:constant fixnum))
(:info fixed)
(:results (context :scs (descriptor-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:result-types t tagged-num)
(:note "more-arg-context")
(:generator 5
;; SP at this point points at the last arg pushed.
;; Point to the first more-arg, not above it.
(inst lea context (make-ea :qword :base rsp-tn
- :index count :scale 1
- :disp (- (+ (fixnumize fixed) n-word-bytes))))
+ :index count :scale 1
+ :disp (- (+ (fixnumize fixed) n-word-bytes))))
(unless (zerop fixed)
(inst sub count (fixnumize fixed)))))
(:save-p :compute-only)
(:generator 3
(let ((err-lab
- (generate-error-code vop invalid-arg-count-error nargs)))
+ (generate-error-code vop invalid-arg-count-error nargs)))
(if (zerop count)
- (inst test nargs nargs) ; smaller instruction
- (inst cmp nargs (fixnumize count)))
+ (inst test nargs nargs) ; smaller instruction
+ (inst cmp nargs (fixnumize count)))
(inst jmp :ne err-lab))))
;;; Various other error signallers.
(macrolet ((def (name error translate &rest args)
- `(define-vop (,name)
- ,@(when translate
- `((:policy :fast-safe)
- (:translate ,translate)))
- (:args ,@(mapcar (lambda (arg)
- `(,arg :scs (any-reg descriptor-reg)))
- args))
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 1000
- (error-call vop ,error ,@args)))))
+ `(define-vop (,name)
+ ,@(when translate
+ `((:policy :fast-safe)
+ (:translate ,translate)))
+ (:args ,@(mapcar (lambda (arg)
+ `(,arg :scs (any-reg descriptor-reg)))
+ args))
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1000
+ (error-call vop ,error ,@args)))))
(def arg-count-error invalid-arg-count-error
sb!c::%arg-count-error nargs)
(def type-check-error object-not-type-error sb!c::%type-check-error
(define-vop (set-slot)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg immediate)))
+ (value :scs (descriptor-reg any-reg immediate)))
(:temporary (:sc descriptor-reg) temp)
(:info name offset lowtag)
(:ignore name)
(:results)
(:generator 1
(if (sc-is value immediate)
- (let ((val (tn-value value)))
- (move-immediate (make-ea :qword
- :base object
- :disp (- (* offset n-word-bytes)
- lowtag))
- (etypecase val
- (integer
- (fixnumize val))
- (symbol
- (+ nil-value (static-symbol-offset val)))
- (character
- (logior (ash (char-code val) n-widetag-bits)
- character-widetag)))
- temp))
- ;; Else, value not immediate.
- (storew value object offset lowtag))))
+ (let ((val (tn-value value)))
+ (move-immediate (make-ea :qword
+ :base object
+ :disp (- (* offset n-word-bytes)
+ lowtag))
+ (etypecase val
+ (integer
+ (fixnumize val))
+ (symbol
+ (+ nil-value (static-symbol-offset val)))
+ (character
+ (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)))
+ temp))
+ ;; Else, value not immediate.
+ (storew value object offset lowtag))))
\f
;;(:policy :fast-safe)
(:generator 4
(let ((global-val (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
(inst or tls tls)
(inst jmp :z global-val)
- (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
- unbound-marker-widetag)
+ (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
+ unbound-marker-widetag)
(inst jmp :z global-val)
(inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls)
- value)
+ value)
(inst jmp done)
(emit-label global-val)
(storew value symbol symbol-value-slot other-pointer-lowtag)
(emit-label done))))
;; unithreaded it's a lot simpler ...
-#!-sb-thread
+#!-sb-thread
(define-vop (set cell-set)
(:variant symbol-value-slot other-pointer-lowtag))
(:save-p :compute-only)
(:generator 9
(let* ((err-lab (generate-error-code vop unbound-symbol-error object))
- (ret-lab (gen-label)))
+ (ret-lab (gen-label)))
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst mov value (make-ea :qword :base thread-base-tn
- :index value :scale 1))
+ (inst mov value (make-ea :qword :base thread-base-tn
+ :index value :scale 1))
(inst cmp value unbound-marker-widetag)
(inst jmp :ne ret-lab)
(loadw value object symbol-value-slot other-pointer-lowtag)
(let ((ret-lab (gen-label)))
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
(inst mov value
- (make-ea :qword :base thread-base-tn :index value :scale 1))
+ (make-ea :qword :base thread-base-tn :index value :scale 1))
(inst cmp value unbound-marker-widetag)
(inst jmp :ne ret-lab)
(loadw value object symbol-value-slot other-pointer-lowtag)
(define-vop (locked-symbol-global-value-add)
(:args (object :scs (descriptor-reg) :to :result)
- (value :scs (any-reg) :target result))
+ (value :scs (any-reg) :target result))
(:arg-types * tagged-num)
(:results (result :scs (any-reg) :from (:argument 1)))
(:policy :fast)
(move result value)
(inst lock)
(inst add (make-ea :qword :base object
- :disp (- (* symbol-value-slot n-word-bytes)
- other-pointer-lowtag))
- value)))
+ :disp (- (* symbol-value-slot n-word-bytes)
+ other-pointer-lowtag))
+ value)))
#!+sb-thread
(define-vop (boundp)
(:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
(:generator 9
(if not-p
- (let ((not-target (gen-label)))
- (loadw value object symbol-value-slot other-pointer-lowtag)
- (inst cmp value unbound-marker-widetag)
- (inst jmp :ne not-target)
- (loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst cmp (make-ea :qword :base thread-base-tn
- :index value :scale 1) unbound-marker-widetag)
- (inst jmp :e target)
- (emit-label not-target))
- (progn
- (loadw value object symbol-value-slot other-pointer-lowtag)
- (inst cmp value unbound-marker-widetag)
- (inst jmp :ne target)
- (loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst cmp (make-ea :qword :base thread-base-tn :index value :scale 1)
- unbound-marker-widetag)
- (inst jmp :ne target)))))
+ (let ((not-target (gen-label)))
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (inst cmp value unbound-marker-widetag)
+ (inst jmp :ne not-target)
+ (loadw value object symbol-tls-index-slot other-pointer-lowtag)
+ (inst cmp (make-ea :qword :base thread-base-tn
+ :index value :scale 1) unbound-marker-widetag)
+ (inst jmp :e target)
+ (emit-label not-target))
+ (progn
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (inst cmp value unbound-marker-widetag)
+ (inst jmp :ne target)
+ (loadw value object symbol-tls-index-slot other-pointer-lowtag)
+ (inst cmp (make-ea :qword :base thread-base-tn :index value :scale 1)
+ unbound-marker-widetag)
+ (inst jmp :ne target)))))
#!-sb-thread
(define-vop (boundp)
\f
;;;; fdefinition (FDEFN) objects
-(define-vop (fdefn-fun cell-ref) ; /pfw - alpha
+(define-vop (fdefn-fun cell-ref) ; /pfw - alpha
(:variant fdefn-fun-slot other-pointer-lowtag))
(define-vop (safe-fdefn-fun)
(:policy :fast-safe)
(:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
- (fdefn :scs (descriptor-reg)))
+ (fdefn :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) raw)
(:temporary (:sc byte-reg) type)
(:results (result :scs (descriptor-reg)))
(:generator 38
(load-type type function (- fun-pointer-lowtag))
(inst lea raw
- (make-ea :byte :base function
- :disp (- (* simple-fun-code-offset n-word-bytes)
- fun-pointer-lowtag)))
+ (make-ea :byte :base function
+ :disp (- (* simple-fun-code-offset n-word-bytes)
+ fun-pointer-lowtag)))
(inst cmp type simple-fun-header-widetag)
(inst jmp :e NORMAL-FUN)
(inst lea raw (make-fixup "closure_tramp" :foreign))
(:generator 38
(storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
(storew (make-fixup "undefined_tramp" :foreign)
- fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+ fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(move result fdefn)))
\f
;;;; binding and unbinding
#!+sb-thread
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
- (symbol :scs (descriptor-reg)))
+ (symbol :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) tls-index temp bsp)
(:generator 5
(let ((tls-index-valid (gen-label)))
(loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(inst add bsp (* binding-size n-word-bytes))
(store-tl-symbol-value bsp *binding-stack-pointer* temp)
-
+
(inst or tls-index tls-index)
(inst jmp :ne tls-index-valid)
;; allocate a new tls-index
(load-symbol-value tls-index *free-tls-index*)
- (inst add tls-index 8) ;XXX surely we can do this more
+ (inst add tls-index 8) ;XXX surely we can do this more
(store-symbol-value tls-index *free-tls-index*) ;succintly
(inst sub tls-index 8)
(storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(emit-label tls-index-valid)
(inst mov temp
- (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
+ (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
(storew temp bsp (- binding-value-slot binding-size))
(storew symbol bsp (- binding-symbol-slot binding-size))
(inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
- val))))
+ val))))
#!-sb-thread
(define-vop (bind)
#!+sb-thread
(define-vop (unbind)
- ;; four temporaries?
+ ;; four temporaries?
(:temporary (:sc unsigned-reg) symbol value bsp tls-index)
(:generator 0
(load-tl-symbol-value bsp *binding-stack-pointer*)
(loadw symbol bsp (- binding-symbol-slot binding-size))
(loadw value bsp (- binding-value-slot binding-size))
- (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+ (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
value)
(defknown %instance-set-conditional (instance index t t) t
- (unsafe))
+ (unsafe))
(define-vop (instance-set-conditional)
(:translate %instance-set-conditional)
(:args (object :scs (descriptor-reg) :to :eval)
- (slot :scs (any-reg) :to :result)
- (old-value :scs (descriptor-reg any-reg) :target rax)
- (new-value :scs (descriptor-reg any-reg)))
+ (slot :scs (any-reg) :to :result)
+ (old-value :scs (descriptor-reg any-reg) :target rax)
+ (new-value :scs (descriptor-reg any-reg)))
(:arg-types instance positive-fixnum * *)
(:temporary (:sc descriptor-reg :offset rax-offset
- :from (:argument 2) :to :result :target result) rax)
+ :from (:argument 2) :to :result :target result) rax)
(:results (result :scs (descriptor-reg any-reg)))
;(:guard (backend-featurep :i486))
(:policy :fast-safe)
(move rax old-value)
(inst lock)
(inst cmpxchg (make-ea :qword :base object :index slot :scale 1
- :disp (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))
- new-value)
+ :disp (- (* instance-slots-offset n-word-bytes)
+ instance-pointer-lowtag))
+ new-value)
(move result rax)))
(inst shl tmp 3)
(inst sub tmp index)
(inst mov
- value
- (make-ea :qword
- :base object
- :index tmp
- :disp (- (* (1- instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag)))))
+ value
+ (make-ea :qword
+ :base object
+ :index tmp
+ :disp (- (* (1- instance-slots-offset) n-word-bytes)
+ instance-pointer-lowtag)))))
(define-vop (raw-instance-set/word)
(:translate %raw-instance-set/word)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (unsigned-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (unsigned-reg) :target result))
(:arg-types * tagged-num unsigned-num)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (unsigned-reg)))
(inst shl tmp 3)
(inst sub tmp index)
(inst mov
- (make-ea :qword
- :base object
- :index tmp
- :disp (- (* (1- instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag))
- value)
+ (make-ea :qword
+ :base object
+ :index tmp
+ :disp (- (* (1- instance-slots-offset) n-word-bytes)
+ instance-pointer-lowtag))
+ value)
(move result value)))
(define-vop (raw-instance-ref/single)
(:translate %raw-instance-ref/single)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:temporary (:sc unsigned-reg) tmp)
(:results (value :scs (single-reg)))
(:translate %raw-instance-set/single)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (single-reg) :target result))
(:arg-types * positive-fixnum single-float)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (single-reg)))
:base object
:index tmp
:disp (- (* (1- instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag))
+ instance-pointer-lowtag))
value)
(unless (location= result value)
(inst movss result value))))
(:translate %raw-instance-ref/double)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:temporary (:sc unsigned-reg) tmp)
(:results (value :scs (double-reg)))
(:translate %raw-instance-set/double)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (double-reg) :target result))
(:arg-types * positive-fixnum double-float)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (double-reg)))
:base object
:index tmp
:disp (- (* (1- instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag))
+ instance-pointer-lowtag))
value)
(unless (location= result value)
(inst movsd result value))))
(:translate %raw-instance-ref/complex-single)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:temporary (:sc unsigned-reg) tmp)
(:results (value :scs (complex-single-reg)))
(:translate %raw-instance-set/complex-single)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-single-reg) :target result))
(:arg-types * positive-fixnum complex-single-float)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (complex-single-reg)))
(inst shl tmp 3)
(inst sub tmp index)
(let ((value-real (complex-single-reg-real-tn value))
- (result-real (complex-single-reg-real-tn result)))
+ (result-real (complex-single-reg-real-tn result)))
(inst movss (make-ea :dword
:base object
:index tmp
:disp (- (* (1- instance-slots-offset) n-word-bytes)
instance-pointer-lowtag))
- value-real)
+ value-real)
(unless (location= value-real result-real)
- (inst movss result-real value-real)))
+ (inst movss result-real value-real)))
(let ((value-imag (complex-single-reg-imag-tn value))
- (result-imag (complex-single-reg-imag-tn result)))
+ (result-imag (complex-single-reg-imag-tn result)))
(inst movss (make-ea :dword
:base object
:index tmp
:disp (+ (* (1- instance-slots-offset) n-word-bytes)
4
(- instance-pointer-lowtag)))
- value-imag)
+ value-imag)
(unless (location= value-imag result-imag)
- (inst movss result-imag value-imag)))))
+ (inst movss result-imag value-imag)))))
(define-vop (raw-instance-ref/complex-double)
(:translate %raw-instance-ref/complex-double)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:temporary (:sc unsigned-reg) tmp)
(:results (value :scs (complex-double-reg)))
(:translate %raw-instance-set/complex-double)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-double-reg) :target result))
(:arg-types * positive-fixnum complex-double-float)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (complex-double-reg)))
(inst shl tmp 3)
(inst sub tmp index)
(let ((value-real (complex-double-reg-real-tn value))
- (result-real (complex-double-reg-real-tn result)))
+ (result-real (complex-double-reg-real-tn result)))
(inst movsd (make-ea :dword
:base object
:index tmp
:disp (- (* (- instance-slots-offset 2) n-word-bytes)
instance-pointer-lowtag))
- value-real)
+ value-real)
(unless (location= value-real result-real)
- (inst movsd result-real value-real)))
+ (inst movsd result-real value-real)))
(let ((value-imag (complex-double-reg-imag-tn value))
- (result-imag (complex-double-reg-imag-tn result)))
+ (result-imag (complex-double-reg-imag-tn result)))
(inst movsd (make-ea :dword
:base object
:index tmp
:disp (- (* (1- instance-slots-offset) n-word-bytes)
instance-pointer-lowtag))
- value-imag)
+ value-imag)
(unless (location= value-imag result-imag)
- (inst movsd result-imag value-imag)))))
+ (inst movsd result-imag value-imag)))))
#!+sb-unicode
(define-vop (move-to-character)
(:args (x :scs (any-reg descriptor-reg) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (character-reg)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:note "character untagging")
(:generator 1
(move y x)
(:note "character untagging")
(:generator 1
(let ((y-wide-tn (make-random-tn
- :kind :normal
- :sc (sc-or-lose 'any-reg)
- :offset (tn-offset y))))
+ :kind :normal
+ :sc (sc-or-lose 'any-reg)
+ :offset (tn-offset y))))
(move y-wide-tn x)
(inst shr y-wide-tn 8)
(inst and y-wide-tn #xff))))
(define-move-vop move-to-character :move
- (any-reg #!-sb-unicode control-stack)
+ (any-reg #!-sb-unicode control-stack)
(character-reg))
;;; Move an untagged char to a tagged representation.
(:note "character tagging")
(:generator 1
(move (make-random-tn :kind :normal :sc (sc-or-lose 'character-reg)
- :offset (tn-offset y))
- x)
+ :offset (tn-offset y))
+ x)
(inst shl y n-widetag-bits)
(inst or y character-widetag)
(inst and y #xffff)))
(define-move-vop move-from-character :move
- (character-reg)
+ (character-reg)
(any-reg descriptor-reg #!-sb-unicode control-stack))
;;; Move untagged character values.
(define-vop (character-move)
(:args (x :target y
- :scs (character-reg)
- :load-if (not (location= x y))))
+ :scs (character-reg)
+ :load-if (not (location= x y))))
(:results (y :scs (character-reg character-stack)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:note "character move")
(:effects)
(:affected)
;;; Move untagged character arguments/return-values.
(define-vop (move-character-arg)
(:args (x :target y
- :scs (character-reg))
- (fp :scs (any-reg)
- :load-if (not (sc-is y character-reg))))
+ :scs (character-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y character-reg))))
(:results (y))
(:note "character arg move")
(:generator 0
(character-stack
#!-sb-unicode
(inst mov
- ;; FIXME: naked 8 (should be... what? n-register-bytes?
- ;; n-word-bytes? Dunno.
- (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 8)))
- x)
+ ;; FIXME: naked 8 (should be... what? n-register-bytes?
+ ;; n-word-bytes? Dunno.
+ (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 8)))
+ x)
#!+sb-unicode
(if (= (tn-offset fp) esp-offset)
- (storew x fp (tn-offset y)) ; c-call
- (storew x fp (- (1+ (tn-offset y)))))))))
+ (storew x fp (tn-offset y)) ; c-call
+ (storew x fp (- (1+ (tn-offset y)))))))))
(define-move-vop move-character-arg :move-arg
(any-reg character-reg) (character-reg))
(:args (code :scs (unsigned-reg unsigned-stack) :target eax))
(:arg-types positive-fixnum)
(:temporary (:sc unsigned-reg :offset rax-offset :target res
- :from (:argument 0) :to (:result 0))
- eax)
+ :from (:argument 0) :to (:result 0))
+ eax)
(:results (res :scs (character-reg)))
(:result-types character)
(:generator 1
;;; comparison of CHARACTERs
(define-vop (character-compare)
(:args (x :scs (character-reg character-stack))
- (y :scs (character-reg)
- :load-if (not (and (sc-is x character-reg)
- (sc-is y character-stack)))))
+ (y :scs (character-reg)
+ :load-if (not (and (sc-is x character-reg)
+ (sc-is y character-stack)))))
(:arg-types character character)
(:conditional)
(:info target not-p)
(:translate stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to :eval)
- (offset :scs (any-reg) :target temp))
+ (offset :scs (any-reg) :target temp))
(:arg-types system-area-pointer positive-fixnum)
(:temporary (:sc unsigned-reg :from (:argument 1)) temp)
(:results (result :scs (descriptor-reg)))
(move temp offset)
(inst neg temp)
(inst mov result
- (make-ea :qword :base sap :disp (- n-word-bytes) :index temp))))
+ (make-ea :qword :base sap :disp (- n-word-bytes) :index temp))))
(define-vop (read-control-stack-c)
(:translate stack-ref)
(:result-types *)
(:generator 5
(inst mov result (make-ea :qword :base sap
- :disp (- (* (1+ index) n-word-bytes))))))
+ :disp (- (* (1+ index) n-word-bytes))))))
(define-vop (write-control-stack)
(:translate %set-stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to :eval)
- (offset :scs (any-reg) :target temp)
- (value :scs (descriptor-reg) :to :result :target result))
+ (offset :scs (any-reg) :target temp)
+ (value :scs (descriptor-reg) :to :result :target result))
(:arg-types system-area-pointer positive-fixnum *)
(:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
(:results (result :scs (descriptor-reg)))
(move temp offset)
(inst neg temp)
(inst mov
- (make-ea :qword :base sap :disp (- n-word-bytes) :index temp) value)
+ (make-ea :qword :base sap :disp (- n-word-bytes) :index temp) value)
(move result value)))
(define-vop (write-control-stack-c)
(:translate %set-stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (value :scs (descriptor-reg) :target result))
+ (value :scs (descriptor-reg) :target result))
(:info index)
(:arg-types system-area-pointer (:constant (signed-byte 29)) *)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 5
(inst mov (make-ea :qword :base sap
- :disp (- (* (1+ index) n-word-bytes)))
- value)
+ :disp (- (* (1+ index) n-word-bytes)))
+ value)
(move result value)))
(define-vop (code-from-mumble)
(:variant-vars lowtag)
(:generator 5
(let ((bogus (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(loadw temp thing 0 lowtag)
(inst shr temp n-widetag-bits)
(inst jmp :z bogus)
(inst shl temp (1- (integer-length n-word-bytes)))
(unless (= lowtag other-pointer-lowtag)
- (inst add temp (- lowtag other-pointer-lowtag)))
+ (inst add temp (- lowtag other-pointer-lowtag)))
(move code thing)
(inst sub code temp)
(emit-label done)
(assemble (*elsewhere*)
- (emit-label bogus)
- (inst mov code nil-value)
- (inst jmp done)))))
+ (emit-label bogus)
+ (inst mov code nil-value)
+ (inst jmp done)))))
(define-vop (code-from-lra code-from-mumble)
(:translate sb!di::lra-code-header)
(:args (value :scs (unsigned-reg unsigned-stack) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)
- :load-if (not (sc-is value unsigned-reg))
- ))
+ :load-if (not (sc-is value unsigned-reg))
+ ))
(:generator 1
(move result value)))
(:translate sb!di::get-lisp-obj-address)
(:args (thing :scs (descriptor-reg control-stack) :target result))
(:results (result :scs (unsigned-reg)
- :load-if (not (and (sc-is thing descriptor-reg)
- (sc-is result unsigned-stack)))))
+ :load-if (not (and (sc-is thing descriptor-reg)
+ (sc-is result unsigned-stack)))))
(:result-types unsigned-num)
(:generator 1
(move result thing)))
(in-package "SB!VM")
\f
(macrolet ((ea-for-xf-desc (tn slot)
- `(make-ea
- :qword :base ,tn
- :disp (- (* ,slot n-word-bytes)
- other-pointer-lowtag))))
+ `(make-ea
+ :qword :base ,tn
+ :disp (- (* ,slot n-word-bytes)
+ other-pointer-lowtag))))
(defun ea-for-df-desc (tn)
(ea-for-xf-desc tn double-float-value-slot))
;; complex floats
(ea-for-xf-desc tn complex-double-float-imag-slot)))
(macrolet ((ea-for-xf-stack (tn kind)
- (declare (ignore kind))
- `(make-ea
- :qword :base rbp-tn
- :disp (- (* (+ (tn-offset ,tn) 1)
- n-word-bytes)))))
+ (declare (ignore kind))
+ `(make-ea
+ :qword :base rbp-tn
+ :disp (- (* (+ (tn-offset ,tn) 1)
+ n-word-bytes)))))
(defun ea-for-sf-stack (tn)
(ea-for-xf-stack tn :single))
(defun ea-for-df-stack (tn)
;;; complex float stack EAs
(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
- (declare (ignore kind))
- `(make-ea
- :qword :base ,base
- :disp (- (* (+ (tn-offset ,tn)
- (* 1 (ecase ,slot (:real 1) (:imag 2))))
- n-word-bytes)))))
+ (declare (ignore kind))
+ `(make-ea
+ :qword :base ,base
+ :disp (- (* (+ (tn-offset ,tn)
+ (* 1 (ecase ,slot (:real 1) (:imag 2))))
+ n-word-bytes)))))
(defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
(ea-for-cxf-stack tn :single :real base))
(defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
(defun complex-single-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
- :offset (tn-offset x)))
+ :offset (tn-offset x)))
(defun complex-single-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
- :offset (1+ (tn-offset x))))
+ :offset (1+ (tn-offset x))))
(defun complex-double-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
- :offset (tn-offset x)))
+ :offset (tn-offset x)))
(defun complex-double-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
- :offset (1+ (tn-offset x))))
+ :offset (1+ (tn-offset x))))
;;; X is source, Y is destination.
(define-move-fun (load-complex-single 2) (vop x y)
(define-move-fun (store-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((real-tn (complex-single-reg-real-tn x))
- (imag-tn (complex-single-reg-imag-tn x)))
+ (imag-tn (complex-single-reg-imag-tn x)))
(inst movss (ea-for-csf-real-stack y) real-tn)
(inst movss (ea-for-csf-imag-stack y) imag-tn)))
(define-move-fun (store-complex-double 2) (vop x y)
((complex-double-reg) (complex-double-stack))
(let ((real-tn (complex-double-reg-real-tn x))
- (imag-tn (complex-double-reg-imag-tn x)))
+ (imag-tn (complex-double-reg-imag-tn x)))
(inst movsd (ea-for-cdf-real-stack y) real-tn)
(inst movsd (ea-for-cdf-imag-stack y) imag-tn)))
;;; float register to register moves
(macrolet ((frob (vop sc)
- `(progn
- (define-vop (,vop)
- (:args (x :scs (,sc)
- :target y
- :load-if (not (location= x y))))
- (:results (y :scs (,sc)
- :load-if (not (location= x y))))
- (:note "float move")
- (:generator 0
- (unless (location= y x)
- (inst movq y x))))
- (define-move-vop ,vop :move (,sc) (,sc)))))
+ `(progn
+ (define-vop (,vop)
+ (:args (x :scs (,sc)
+ :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (,sc)
+ :load-if (not (location= x y))))
+ (:note "float move")
+ (:generator 0
+ (unless (location= y x)
+ (inst movq y x))))
+ (define-move-vop ,vop :move (,sc) (,sc)))))
(frob single-move single-reg)
(frob double-move double-reg))
(unless (location= x y)
;; Note the complex-float-regs are aligned to every second
;; float register so there is not need to worry about overlap.
- ;; (It would be better to put the imagpart in the top half of the
+ ;; (It would be better to put the imagpart in the top half of the
;; register, or something, but let's worry about that later)
(let ((x-real (complex-single-reg-real-tn x))
- (y-real (complex-single-reg-real-tn y)))
- (inst movq y-real x-real))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst movq y-real x-real))
(let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst movq y-imag x-imag)))))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst movq y-imag x-imag)))))
(define-vop (complex-single-move complex-float-move)
(:args (x :scs (complex-single-reg) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
(define-move-vop complex-single-move :move
(complex-single-reg) (complex-single-reg))
(define-vop (complex-double-move complex-float-move)
(:args (x :scs (complex-double-reg)
- :target y :load-if (not (location= x y))))
+ :target y :load-if (not (location= x y))))
(:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
(define-move-vop complex-double-move :move
(complex-double-reg) (complex-double-reg))
(:note "float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- double-float-widetag
- double-float-size
- node)
+ double-float-widetag
+ double-float-size
+ node)
(inst movsd (ea-for-df-desc y) x))))
(define-move-vop move-from-double :move
(double-reg) (descriptor-reg))
(:note "complex float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- complex-single-float-widetag
- complex-single-float-size
- node)
+ complex-single-float-widetag
+ complex-single-float-size
+ node)
(let ((real-tn (complex-single-reg-real-tn x)))
- (inst movss (ea-for-csf-real-desc y) real-tn))
+ (inst movss (ea-for-csf-real-desc y) real-tn))
(let ((imag-tn (complex-single-reg-imag-tn x)))
- (inst movss (ea-for-csf-imag-desc y) imag-tn)))))
+ (inst movss (ea-for-csf-imag-desc y) imag-tn)))))
(define-move-vop move-from-complex-single :move
(complex-single-reg) (descriptor-reg))
(:note "complex float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- complex-double-float-widetag
- complex-double-float-size
- node)
+ complex-double-float-widetag
+ complex-double-float-size
+ node)
(let ((real-tn (complex-double-reg-real-tn x)))
- (inst movsd (ea-for-cdf-real-desc y) real-tn))
+ (inst movsd (ea-for-cdf-real-desc y) real-tn))
(let ((imag-tn (complex-double-reg-imag-tn x)))
- (inst movsd (ea-for-cdf-imag-desc y) imag-tn)))))
+ (inst movsd (ea-for-cdf-imag-desc y) imag-tn)))))
(define-move-vop move-from-complex-double :move
(complex-double-reg) (descriptor-reg))
;;; Move from a descriptor to a complex float register.
(macrolet ((frob (name sc format)
- `(progn
- (define-vop (,name)
- (:args (x :scs (descriptor-reg)))
- (:results (y :scs (,sc)))
- (:note "pointer to complex float coercion")
- (:generator 2
- (let ((real-tn (complex-double-reg-real-tn y)))
- ,@(ecase
- format
- (:single
- '((inst movss real-tn (ea-for-csf-real-desc x))))
- (:double
- '((inst movsd real-tn (ea-for-cdf-real-desc x))))))
- (let ((imag-tn (complex-double-reg-imag-tn y)))
- ,@(ecase
- format
- (:single
- '((inst movss imag-tn (ea-for-csf-imag-desc x))))
- (:double
- '((inst movsd imag-tn (ea-for-cdf-imag-desc x))))))))
- (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (,sc)))
+ (:note "pointer to complex float coercion")
+ (:generator 2
+ (let ((real-tn (complex-double-reg-real-tn y)))
+ ,@(ecase
+ format
+ (:single
+ '((inst movss real-tn (ea-for-csf-real-desc x))))
+ (:double
+ '((inst movsd real-tn (ea-for-cdf-real-desc x))))))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ ,@(ecase
+ format
+ (:single
+ '((inst movss imag-tn (ea-for-csf-imag-desc x))))
+ (:double
+ '((inst movsd imag-tn (ea-for-cdf-imag-desc x))))))))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-complex-single complex-single-reg :single)
(frob move-to-complex-double complex-double-reg :double))
\f
;;; the general MOVE-ARG VOP
(macrolet ((frob (name sc stack-sc format)
- `(progn
- (define-vop (,name)
- (:args (x :scs (,sc) :target y)
- (fp :scs (any-reg)
- :load-if (not (sc-is y ,sc))))
- (:results (y))
- (:note "float argument move")
- (:generator ,(case format (:single 2) (:double 3) )
- (sc-case y
- (,sc
- (unless (location= x y)
- (inst movq y x)))
- (,stack-sc
- (if (= (tn-offset fp) esp-offset)
- (let* ((offset (* (tn-offset y) n-word-bytes))
- (ea (make-ea :dword :base fp :disp offset)))
- ,@(ecase format
- (:single '((inst movss ea x)))
- (:double '((inst movsd ea x)))))
- (let ((ea (make-ea
- :dword :base fp
- :disp (- (* (+ (tn-offset y)
- ,(case format
- (:single 1)
- (:double 2) ))
- n-word-bytes)))))
- ,@(ecase format
- (:single '((inst movss ea x)))
- (:double '((inst movsd ea x))))))))))
- (define-move-vop ,name :move-arg
- (,sc descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "float argument move")
+ (:generator ,(case format (:single 2) (:double 3) )
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (inst movq y x)))
+ (,stack-sc
+ (if (= (tn-offset fp) esp-offset)
+ (let* ((offset (* (tn-offset y) n-word-bytes))
+ (ea (make-ea :dword :base fp :disp offset)))
+ ,@(ecase format
+ (:single '((inst movss ea x)))
+ (:double '((inst movsd ea x)))))
+ (let ((ea (make-ea
+ :dword :base fp
+ :disp (- (* (+ (tn-offset y)
+ ,(case format
+ (:single 1)
+ (:double 2) ))
+ n-word-bytes)))))
+ ,@(ecase format
+ (:single '((inst movss ea x)))
+ (:double '((inst movsd ea x))))))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
(frob move-single-float-arg single-reg single-stack :single)
(frob move-double-float-arg double-reg double-stack :double))
;;;; complex float MOVE-ARG VOP
(macrolet ((frob (name sc stack-sc format)
- `(progn
- (define-vop (,name)
- (:args (x :scs (,sc) :target y)
- (fp :scs (any-reg)
- :load-if (not (sc-is y ,sc))))
- (:results (y))
- (:note "complex float argument move")
- (:generator ,(ecase format (:single 2) (:double 3))
- (sc-case y
- (,sc
- (unless (location= x y)
- (let ((x-real (complex-double-reg-real-tn x))
- (y-real (complex-double-reg-real-tn y)))
- (inst movsd y-real x-real))
- (let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (inst movsd y-imag x-imag))))
- (,stack-sc
- (let ((real-tn (complex-double-reg-real-tn x)))
- ,@(ecase format
- (:single
- '((inst movss
- (ea-for-csf-real-stack y fp)
- real-tn)))
- (:double
- '((inst movsd
- (ea-for-cdf-real-stack y fp)
- real-tn)))))
- (let ((imag-tn (complex-double-reg-imag-tn x)))
- ,@(ecase format
- (:single
- '((inst movss
- (ea-for-csf-imag-stack y fp) imag-tn)))
- (:double
- '((inst movsd
- (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
- (define-move-vop ,name :move-arg
- (,sc descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "complex float argument move")
+ (:generator ,(ecase format (:single 2) (:double 3))
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (inst movsd y-real x-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst movsd y-imag x-imag))))
+ (,stack-sc
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ ,@(ecase format
+ (:single
+ '((inst movss
+ (ea-for-csf-real-stack y fp)
+ real-tn)))
+ (:double
+ '((inst movsd
+ (ea-for-cdf-real-stack y fp)
+ real-tn)))))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ ,@(ecase format
+ (:single
+ '((inst movss
+ (ea-for-csf-imag-stack y fp) imag-tn)))
+ (:double
+ '((inst movsd
+ (ea-for-cdf-imag-stack y fp) imag-tn)))))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
(frob move-complex-single-float-arg
- complex-single-reg complex-single-stack :single)
+ complex-single-reg complex-single-stack :single)
(frob move-complex-double-float-arg
- complex-double-reg complex-double-stack :double))
+ complex-double-reg complex-double-stack :double))
(define-move-vop move-arg :move-arg
(single-reg double-reg
(:save-p :compute-only))
(macrolet ((frob (name sc ptype)
- `(define-vop (,name float-op)
- (:args (x :scs (,sc) :target r)
- (y :scs (,sc)))
- (:results (r :scs (,sc)))
- (:arg-types ,ptype ,ptype)
- (:result-types ,ptype))))
+ `(define-vop (,name float-op)
+ (:args (x :scs (,sc) :target r)
+ (y :scs (,sc)))
+ (:results (r :scs (,sc)))
+ (:arg-types ,ptype ,ptype)
+ (:result-types ,ptype))))
(frob single-float-op single-reg single-float)
(frob double-float-op double-reg double-float))
(macrolet ((generate (movinst opinst commutative)
- `(progn
- (cond
- ((location= x r)
- (inst ,opinst x y))
- ((and ,commutative (location= y r))
- (inst ,opinst y x))
- ((not (location= r y))
- (inst ,movinst r x)
- (inst ,opinst r y))
- (t
- (inst ,movinst tmp x)
- (inst ,opinst tmp y)
- (inst ,movinst r tmp)))))
- (frob (op sinst sname scost dinst dname dcost commutative)
- `(progn
- (define-vop (,sname single-float-op)
- (:translate ,op)
- (:temporary (:sc single-reg) tmp)
- (:generator ,scost
- (generate movss ,sinst ,commutative)))
- (define-vop (,dname double-float-op)
- (:translate ,op)
- (:temporary (:sc single-reg) tmp)
- (:generator ,dcost
+ `(progn
+ (cond
+ ((location= x r)
+ (inst ,opinst x y))
+ ((and ,commutative (location= y r))
+ (inst ,opinst y x))
+ ((not (location= r y))
+ (inst ,movinst r x)
+ (inst ,opinst r y))
+ (t
+ (inst ,movinst tmp x)
+ (inst ,opinst tmp y)
+ (inst ,movinst r tmp)))))
+ (frob (op sinst sname scost dinst dname dcost commutative)
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,op)
+ (:temporary (:sc single-reg) tmp)
+ (:generator ,scost
+ (generate movss ,sinst ,commutative)))
+ (define-vop (,dname double-float-op)
+ (:translate ,op)
+ (:temporary (:sc single-reg) tmp)
+ (:generator ,dcost
(generate movsd ,dinst ,commutative))))))
(frob + addss +/single-float 2 addsd +/double-float 2 t)
(frob - subss -/single-float 2 subsd -/double-float 2 nil)
\f
(macrolet ((frob ((name translate sc type) &body body)
- `(define-vop (,name)
- (:args (x :scs (,sc)))
- (:results (y :scs (,sc)))
- (:translate ,translate)
- (:policy :fast-safe)
- (:arg-types ,type)
- (:result-types ,type)
- (:temporary (:sc any-reg) hex8)
- (:temporary
- (:sc ,sc) xmm)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 1
- (note-this-location vop :internal-error)
- ;; we should be able to do this better. what we
- ;; really would like to do is use the target as the
- ;; temp whenever it's not also the source
- (unless (location= x y)
- (inst movq y x))
- ,@body))))
+ `(define-vop (,name)
+ (:args (x :scs (,sc)))
+ (:results (y :scs (,sc)))
+ (:translate ,translate)
+ (:policy :fast-safe)
+ (:arg-types ,type)
+ (:result-types ,type)
+ (:temporary (:sc any-reg) hex8)
+ (:temporary
+ (:sc ,sc) xmm)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ ;; we should be able to do this better. what we
+ ;; really would like to do is use the target as the
+ ;; temp whenever it's not also the source
+ (unless (location= x y)
+ (inst movq y x))
+ ,@body))))
(frob (%negate/double-float %negate double-reg double-float)
- (inst lea hex8 (make-ea :qword :disp 1))
- (inst ror hex8 1) ; #x8000000000000000
- (inst movd xmm hex8)
- (inst xorpd y xmm))
+ (inst lea hex8 (make-ea :qword :disp 1))
+ (inst ror hex8 1) ; #x8000000000000000
+ (inst movd xmm hex8)
+ (inst xorpd y xmm))
(frob (%negate/single-float %negate single-reg single-float)
- (inst lea hex8 (make-ea :qword :disp 1))
- (inst rol hex8 31)
- (inst movd xmm hex8)
- (inst xorps y xmm))
+ (inst lea hex8 (make-ea :qword :disp 1))
+ (inst rol hex8 31)
+ (inst movd xmm hex8)
+ (inst xorps y xmm))
(frob (abs/double-float abs double-reg double-float)
- (inst mov hex8 -1)
- (inst shr hex8 1)
- (inst movd xmm hex8)
- (inst andpd y xmm))
+ (inst mov hex8 -1)
+ (inst shr hex8 1)
+ (inst movd xmm hex8)
+ (inst andpd y xmm))
(frob (abs/single-float abs single-reg single-float)
- (inst mov hex8 -1)
- (inst shr hex8 33)
- (inst movd xmm hex8)
- (inst andps y xmm)))
+ (inst mov hex8 -1)
+ (inst shr hex8 33)
+ (inst movd xmm hex8)
+ (inst andps y xmm)))
\f
;;;; comparison
;; if PF&CF, there was a NaN involved => not equal
;; otherwise, ZF => equal
(cond (not-p
- (inst jmp :p target)
- (inst jmp :ne target))
- (t
- (let ((not-lab (gen-label)))
- (inst jmp :p not-lab)
- (inst jmp :e target)
- (emit-label not-lab))))))
+ (inst jmp :p target)
+ (inst jmp :ne target))
+ (t
+ (let ((not-lab (gen-label)))
+ (inst jmp :p not-lab)
+ (inst jmp :e target)
+ (emit-label not-lab))))))
(define-vop (=/double-float double-float-compare)
(:translate =)
(note-this-location vop :internal-error)
(inst comisd x y)
(cond (not-p
- (inst jmp :p target)
- (inst jmp :ne target))
- (t
- (let ((not-lab (gen-label)))
- (inst jmp :p not-lab)
- (inst jmp :e target)
- (emit-label not-lab))))))
+ (inst jmp :p target)
+ (inst jmp :ne target))
+ (t
+ (let ((not-lab (gen-label)))
+ (inst jmp :p not-lab)
+ (inst jmp :e target)
+ (emit-label not-lab))))))
;; XXX all of these probably have bad NaN behaviour
(define-vop (<double-float double-float-compare)
;;;; conversion
(macrolet ((frob (name translate inst to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (signed-stack signed-reg) :target temp))
- (:temporary (:sc signed-stack) temp)
- (:results (y :scs (,to-sc)))
- (:arg-types signed-num)
- (:result-types ,to-type)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (sc-case x
- (signed-reg
- (inst mov temp x)
- (note-this-location vop :internal-error)
- (inst ,inst y temp))
- (signed-stack
- (note-this-location vop :internal-error)
- (inst ,inst y x)))))))
+ `(define-vop (,name)
+ (:args (x :scs (signed-stack signed-reg) :target temp))
+ (:temporary (:sc signed-stack) temp)
+ (:results (y :scs (,to-sc)))
+ (:arg-types signed-num)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (sc-case x
+ (signed-reg
+ (inst mov temp x)
+ (note-this-location vop :internal-error)
+ (inst ,inst y temp))
+ (signed-stack
+ (note-this-location vop :internal-error)
+ (inst ,inst y x)))))))
(frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
(frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (,from-sc) :target y))
- (:results (y :scs (,to-sc)))
- (:arg-types ,from-type)
- (:result-types ,to-type)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 2
- (note-this-location vop :internal-error)
- (inst ,inst y x)))))
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc) :target y))
+ (:results (y :scs (,to-sc)))
+ (:arg-types ,from-type)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 2
+ (note-this-location vop :internal-error)
+ (inst ,inst y x)))))
(frob %single-float/double-float %single-float cvtsd2ss double-reg
- double-float single-reg single-float)
+ double-float single-reg single-float)
- (frob %double-float/single-float %double-float cvtss2sd
- single-reg single-float double-reg double-float))
+ (frob %double-float/single-float %double-float cvtss2sd
+ single-reg single-float double-reg double-float))
(macrolet ((frob (trans inst from-sc from-type round-p)
(declare (ignore round-p))
- `(define-vop (,(symbolicate trans "/" from-type))
- (:args (x :scs (,from-sc)))
- (:temporary (:sc any-reg) temp-reg)
- (:results (y :scs (signed-reg)))
- (:arg-types ,from-type)
- (:result-types signed-num)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline float truncate")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (sc-case y
- (signed-stack
- (inst ,inst temp-reg x)
- (move y temp-reg))
- (signed-reg
- (inst ,inst y x)
- ))))))
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc)))
+ (:temporary (:sc any-reg) temp-reg)
+ (:results (y :scs (signed-reg)))
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (sc-case y
+ (signed-stack
+ (inst ,inst temp-reg x)
+ (move y temp-reg))
+ (signed-reg
+ (inst ,inst y x)
+ ))))))
(frob %unary-truncate cvttss2si single-reg single-float nil)
(frob %unary-truncate cvttsd2si double-reg double-float nil)
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
- :load-if (not (or (and (sc-is bits signed-stack)
- (sc-is res single-reg))
- (and (sc-is bits signed-stack)
- (sc-is res single-stack)
- (location= bits res))))))
+ :load-if (not (or (and (sc-is bits signed-stack)
+ (sc-is res single-reg))
+ (and (sc-is bits signed-stack)
+ (sc-is res single-stack)
+ (location= bits res))))))
(:results (res :scs (single-reg single-stack)))
(:arg-types signed-num)
(:result-types single-float)
(:generator 4
(sc-case res
(single-stack
- (sc-case bits
- (signed-reg
- (inst mov res bits))
- (signed-stack
- (aver (location= bits res)))))
+ (sc-case bits
+ (signed-reg
+ (inst mov res bits))
+ (signed-stack
+ (aver (location= bits res)))))
(single-reg
- (sc-case bits
- (signed-reg
- (inst movd res bits))
- (signed-stack
- (inst movd res bits)))))))
+ (sc-case bits
+ (signed-reg
+ (inst movd res bits))
+ (signed-stack
+ (inst movd res bits)))))))
(define-vop (make-double-float)
(:args (hi-bits :scs (signed-reg))
- (lo-bits :scs (unsigned-reg)))
+ (lo-bits :scs (unsigned-reg)))
(:results (res :scs (double-reg)))
(:temporary (:sc unsigned-reg) temp)
(:arg-types signed-num unsigned-num)
(define-vop (single-float-bits)
(:args (float :scs (single-reg descriptor-reg)
- :load-if (not (sc-is float single-stack))))
+ :load-if (not (sc-is float single-stack))))
(:results (bits :scs (signed-reg)))
(:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
(:arg-types single-float)
(sc-case bits
(signed-reg
(sc-case float
- (single-reg
- (inst movss stack-temp float)
- (move bits stack-temp))
- (single-stack
- (move bits float))
- (descriptor-reg
- (move bits float)
- (inst shr bits 32))))
+ (single-reg
+ (inst movss stack-temp float)
+ (move bits stack-temp))
+ (single-stack
+ (move bits float))
+ (descriptor-reg
+ (move bits float)
+ (inst shr bits 32))))
(signed-stack
(sc-case float
- (single-reg
- (inst movss bits float)))))
+ (single-reg
+ (inst movss bits float)))))
;; Sign-extend
(inst shl bits 32)
(inst sar bits 32)))
(define-vop (double-float-high-bits)
(:args (float :scs (double-reg descriptor-reg)
- :load-if (not (sc-is float double-stack))))
+ :load-if (not (sc-is float double-stack))))
(:results (hi-bits :scs (signed-reg)))
(:temporary (:sc signed-stack :from :argument :to :result) temp)
(:arg-types double-float)
(:generator 5
(sc-case float
(double-reg
- (inst movsd temp float)
- (move hi-bits temp))
+ (inst movsd temp float)
+ (move hi-bits temp))
(double-stack
- (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
+ (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
(descriptor-reg
- (loadw hi-bits float double-float-value-slot
- other-pointer-lowtag)))
+ (loadw hi-bits float double-float-value-slot
+ other-pointer-lowtag)))
(inst sar hi-bits 32)))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg descriptor-reg)
- :load-if (not (sc-is float double-stack))))
+ :load-if (not (sc-is float double-stack))))
(:results (lo-bits :scs (unsigned-reg)))
(:temporary (:sc signed-stack :from :argument :to :result) temp)
(:arg-types double-float)
(:generator 5
(sc-case float
(double-reg
- (inst movsd temp float)
- (move lo-bits temp))
+ (inst movsd temp float)
+ (move lo-bits temp))
(double-stack
- (loadw lo-bits ebp-tn (- (1+ (tn-offset float)))))
+ (loadw lo-bits ebp-tn (- (1+ (tn-offset float)))))
(descriptor-reg
- (loadw lo-bits float double-float-value-slot
- other-pointer-lowtag)))
+ (loadw lo-bits float double-float-value-slot
+ other-pointer-lowtag)))
(inst shl lo-bits 32)
(inst shr lo-bits 32)))
(define-vop (make-complex-single-float)
(:translate complex)
(:args (real :scs (single-reg) :to :result :target r
- :load-if (not (location= real r)))
- (imag :scs (single-reg) :to :save))
+ :load-if (not (location= real r)))
+ (imag :scs (single-reg) :to :save))
(:arg-types single-float single-float)
(:results (r :scs (complex-single-reg) :from (:argument 0)
- :load-if (not (sc-is r complex-single-stack))))
+ :load-if (not (sc-is r complex-single-stack))))
(:result-types complex-single-float)
(:note "inline complex single-float creation")
(:policy :fast-safe)
(sc-case r
(complex-single-reg
(let ((r-real (complex-single-reg-real-tn r)))
- (unless (location= real r-real)
- (inst movss r-real real)))
+ (unless (location= real r-real)
+ (inst movss r-real real)))
(let ((r-imag (complex-single-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst movss r-imag imag))))
+ (unless (location= imag r-imag)
+ (inst movss r-imag imag))))
(complex-single-stack
(inst movss (ea-for-csf-real-stack r) real)
(inst movss (ea-for-csf-imag-stack r) imag)))))
(define-vop (make-complex-double-float)
(:translate complex)
(:args (real :scs (double-reg) :target r
- :load-if (not (location= real r)))
- (imag :scs (double-reg) :to :save))
+ :load-if (not (location= real r)))
+ (imag :scs (double-reg) :to :save))
(:arg-types double-float double-float)
(:results (r :scs (complex-double-reg) :from (:argument 0)
- :load-if (not (sc-is r complex-double-stack))))
+ :load-if (not (sc-is r complex-double-stack))))
(:result-types complex-double-float)
(:note "inline complex double-float creation")
(:policy :fast-safe)
(sc-case r
(complex-double-reg
(let ((r-real (complex-double-reg-real-tn r)))
- (unless (location= real r-real)
- (inst movsd r-real real)))
+ (unless (location= real r-real)
+ (inst movsd r-real real)))
(let ((r-imag (complex-double-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst movsd r-imag imag))))
+ (unless (location= imag r-imag)
+ (inst movsd r-imag imag))))
(complex-double-stack
(inst movsd (ea-for-cdf-real-stack r) real)
(inst movsd (ea-for-cdf-imag-stack r) imag)))))
(:policy :fast-safe)
(:generator 3
(cond ((sc-is x complex-single-reg complex-double-reg)
- (let ((value-tn
- (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ offset (tn-offset x)))))
- (unless (location= value-tn r)
- (if (sc-is x complex-single-reg)
- (inst movss r value-tn)
- (inst movsd r value-tn)))))
- ((sc-is r single-reg)
- (let ((ea (sc-case x
- (complex-single-stack
- (ecase offset
- (0 (ea-for-csf-real-stack x))
- (1 (ea-for-csf-imag-stack x))))
- (descriptor-reg
- (ecase offset
- (0 (ea-for-csf-real-desc x))
- (1 (ea-for-csf-imag-desc x)))))))
- (inst movss r ea)))
- ((sc-is r double-reg)
- (let ((ea (sc-case x
- (complex-double-stack
- (ecase offset
- (0 (ea-for-cdf-real-stack x))
- (1 (ea-for-cdf-imag-stack x))))
- (descriptor-reg
- (ecase offset
- (0 (ea-for-cdf-real-desc x))
- (1 (ea-for-cdf-imag-desc x)))))))
- (inst movsd r ea)))
- (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
+ (let ((value-tn
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ offset (tn-offset x)))))
+ (unless (location= value-tn r)
+ (if (sc-is x complex-single-reg)
+ (inst movss r value-tn)
+ (inst movsd r value-tn)))))
+ ((sc-is r single-reg)
+ (let ((ea (sc-case x
+ (complex-single-stack
+ (ecase offset
+ (0 (ea-for-csf-real-stack x))
+ (1 (ea-for-csf-imag-stack x))))
+ (descriptor-reg
+ (ecase offset
+ (0 (ea-for-csf-real-desc x))
+ (1 (ea-for-csf-imag-desc x)))))))
+ (inst movss r ea)))
+ ((sc-is r double-reg)
+ (let ((ea (sc-case x
+ (complex-double-stack
+ (ecase offset
+ (0 (ea-for-cdf-real-stack x))
+ (1 (ea-for-cdf-imag-stack x))))
+ (descriptor-reg
+ (ecase offset
+ (0 (ea-for-cdf-real-desc x))
+ (1 (ea-for-cdf-imag-desc x)))))))
+ (inst movsd r ea)))
+ (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
(define-vop (realpart/complex-single-float complex-float-value)
(:translate realpart)
(:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(define-vop (realpart/complex-double-float complex-float-value)
(:translate realpart)
(:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(define-vop (imagpart/complex-single-float complex-float-value)
(:translate imagpart)
(:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(define-vop (imagpart/complex-double-float complex-float-value)
(:translate imagpart)
(:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(defun offset-next (value dstate)
(declare (type integer value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(+ (sb!disassem:dstate-next-addr dstate) value))
(defparameter *byte-reg-names*
;;; does not use them.
(defun print-reg-with-width (value width stream dstate)
(declare (type full-reg value)
- (type stream stream)
+ (type stream stream)
(type sb!disassem:disassem-state dstate))
(princ (if (and (eq width :byte)
(<= 4 value 7)
(:dword *dword-reg-names*)
(:qword *qword-reg-names*))
value))
- stream)
+ stream)
;; XXX plus should do some source-var notes
)
(defun print-reg (value stream dstate)
(declare (type full-reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value
(inst-operand-size dstate)
- stream
- dstate))
+ stream
+ dstate))
(defun print-reg-default-qword (value stream dstate)
(declare (type full-reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value
(inst-operand-size-default-qword dstate)
- stream
- dstate))
+ stream
+ dstate))
(defun print-byte-reg (value stream dstate)
(declare (type full-reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value :byte stream dstate))
(defun print-addr-reg (value stream dstate)
(declare (type full-reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value +default-address-size+ stream dstate))
;;; Print a register or a memory reference of the given WIDTH.
(declare (type (or list full-reg) value)
(type (member :byte :word :dword :qword) width)
(type boolean sized-p)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(if (typep value 'full-reg)
(print-reg-with-width value width stream dstate)
(print-mem-access value (and sized-p width) stream dstate)))
;;; calling INST-OPERAND-SIZE.
(defun print-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width
value (inst-operand-size dstate) nil stream dstate))
;; memory references.
(defun print-sized-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width
value (inst-operand-size dstate) t stream dstate))
;;; :qword.
(defun print-sized-reg/mem-default-qword (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width
value (inst-operand-size-default-qword dstate) t stream dstate))
(defun print-sized-byte-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width value :byte t stream dstate))
(defun print-sized-word-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width value :word t stream dstate))
(defun print-sized-dword-reg/mem (value stream dstate)
(declare (type (or list full-reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg/mem-with-width value :dword t stream dstate))
(defun print-label (value stream dstate)
;;; prefilters and by printers.
(defun prefilter-wrxb (value dstate)
(declare (type (unsigned-byte 4) value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(sb!disassem:dstate-put-inst-prop dstate 'rex)
(when (plusp (logand value #b1000))
(sb!disassem:dstate-put-inst-prop dstate 'rex-w))
;;; the property OPERAND-SIZE-8 into the DSTATE if VALUE is 0.
(defun prefilter-width (value dstate)
(declare (type bit value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(when (zerop value)
(sb!disassem:dstate-put-inst-prop dstate 'operand-size-8))
value)
;;; A register field that can be extended by REX.R.
(defun prefilter-reg-r (value dstate)
(declare (type reg value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(if (sb!disassem::dstate-get-inst-prop dstate 'rex-r)
(+ value 8)
value))
;;; A register field that can be extended by REX.B.
(defun prefilter-reg-b (value dstate)
(declare (type reg value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(if (sb!disassem::dstate-get-inst-prop dstate 'rex-b)
(+ value 8)
value))
;;; INDEX-REG.
(defun prefilter-reg/mem (value dstate)
(declare (type list value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(let ((mod (first value))
- (r/m (second value)))
+ (r/m (second value)))
(declare (type (unsigned-byte 2) mod)
- (type (unsigned-byte 3) r/m))
+ (type (unsigned-byte 3) r/m))
(let ((full-reg (if (sb!disassem:dstate-get-inst-prop dstate 'rex-b)
(+ r/m 8)
r/m)))
(declare (type full-reg full-reg))
(cond ((= mod #b11)
- ;; registers
- full-reg)
- ((= r/m #b100)
- ;; sib byte
- (let ((sib (sb!disassem:read-suffix 8 dstate)))
- (declare (type (unsigned-byte 8) sib))
- (let ((base-reg (ldb (byte 3 0) sib))
- (index-reg (ldb (byte 3 3) sib))
- (index-scale (ldb (byte 2 6) sib)))
- (declare (type (unsigned-byte 3) base-reg index-reg)
- (type (unsigned-byte 2) index-scale))
- (let* ((offset
- (case mod
- (#b00
- (if (= base-reg #b101)
- (sb!disassem:read-signed-suffix 32 dstate)
- nil))
- (#b01
- (sb!disassem:read-signed-suffix 8 dstate))
- (#b10
- (sb!disassem:read-signed-suffix 32 dstate)))))
- (list (unless (and (= mod #b00) (= base-reg #b101))
+ ;; registers
+ full-reg)
+ ((= r/m #b100)
+ ;; sib byte
+ (let ((sib (sb!disassem:read-suffix 8 dstate)))
+ (declare (type (unsigned-byte 8) sib))
+ (let ((base-reg (ldb (byte 3 0) sib))
+ (index-reg (ldb (byte 3 3) sib))
+ (index-scale (ldb (byte 2 6) sib)))
+ (declare (type (unsigned-byte 3) base-reg index-reg)
+ (type (unsigned-byte 2) index-scale))
+ (let* ((offset
+ (case mod
+ (#b00
+ (if (= base-reg #b101)
+ (sb!disassem:read-signed-suffix 32 dstate)
+ nil))
+ (#b01
+ (sb!disassem:read-signed-suffix 8 dstate))
+ (#b10
+ (sb!disassem:read-signed-suffix 32 dstate)))))
+ (list (unless (and (= mod #b00) (= base-reg #b101))
(if (sb!disassem:dstate-get-inst-prop dstate 'rex-b)
(+ base-reg 8)
base-reg))
- offset
- (unless (= index-reg #b100)
+ offset
+ (unless (= index-reg #b100)
(if (sb!disassem:dstate-get-inst-prop dstate 'rex-x)
(+ index-reg 8)
index-reg))
- (ash 1 index-scale))))))
- ((and (= mod #b00) (= r/m #b101))
- (list 'rip (sb!disassem:read-signed-suffix 32 dstate)) )
- ((= mod #b00)
- (list full-reg))
- ((= mod #b01)
- (list full-reg (sb!disassem:read-signed-suffix 8 dstate)))
- (t ; (= mod #b10)
- (list full-reg (sb!disassem:read-signed-suffix 32 dstate)))))))
+ (ash 1 index-scale))))))
+ ((and (= mod #b00) (= r/m #b101))
+ (list 'rip (sb!disassem:read-signed-suffix 32 dstate)) )
+ ((= mod #b00)
+ (list full-reg))
+ ((= mod #b01)
+ (list full-reg (sb!disassem:read-signed-suffix 8 dstate)))
+ (t ; (= mod #b10)
+ (list full-reg (sb!disassem:read-signed-suffix 32 dstate)))))))
(defun read-address (value dstate)
- (declare (ignore value)) ; always nil anyway
+ (declare (ignore value)) ; always nil anyway
(sb!disassem:read-suffix (width-bits (inst-operand-size dstate)) dstate))
(defun width-bits (width)
:sign-extend t
:use-label #'offset-next
:printer (lambda (value stream dstate)
- (sb!disassem:maybe-note-assembler-routine value nil dstate)
- (print-label value stream dstate)))
+ (sb!disassem:maybe-note-assembler-routine value nil dstate)
+ (print-label value stream dstate)))
(sb!disassem:define-arg-type accum
:printer (lambda (value stream dstate)
- (declare (ignore value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
- (print-reg 0 stream dstate)))
+ (declare (ignore value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-reg 0 stream dstate)))
(sb!disassem:define-arg-type reg
:prefilter #'prefilter-reg-r
;;; argument type definition following this one.
(sb!disassem:define-arg-type signed-imm-data
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
+ (declare (ignore value)) ; always nil anyway
(let ((width (width-bits (inst-operand-size dstate))))
(when (= width 64)
(setf width 32))
;;; register.
(sb!disassem:define-arg-type signed-imm-data-upto-qword
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
+ (declare (ignore value)) ; always nil anyway
(sb!disassem:read-signed-suffix
(width-bits (inst-operand-size dstate))
dstate)))
;;; argument is PUSH.
(sb!disassem:define-arg-type signed-imm-data-default-qword
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
+ (declare (ignore value)) ; always nil anyway
(let ((width (width-bits
(inst-operand-size-default-qword dstate))))
(when (= width 64)
(sb!disassem:define-arg-type signed-imm-byte
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 8 dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 8 dstate)))
(sb!disassem:define-arg-type imm-byte
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-suffix 8 dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix 8 dstate)))
;;; needed for the ret imm16 instruction
(sb!disassem:define-arg-type imm-word-16
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-suffix 16 dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix 16 dstate)))
(sb!disassem:define-arg-type reg/mem
:prefilter #'prefilter-reg/mem
value)
) ; EVAL-WHEN
(sb!disassem:define-arg-type fp-reg
- :prefilter #'prefilter-fp-reg
- :printer #'print-fp-reg)
+ :prefilter #'prefilter-fp-reg
+ :printer #'print-fp-reg)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *conditions*
(let ((vec (make-array 16 :initial-element nil)))
(dolist (cond *conditions*)
(when (null (aref vec (cdr cond)))
- (setf (aref vec (cdr cond)) (car cond))))
+ (setf (aref vec (cdr cond)) (car cond))))
vec))
) ; EVAL-WHEN
(eval-when (:compile-toplevel :execute)
(defun swap-if (direction field1 separator field2)
`(:if (,direction :constant 0)
- (,field1 ,separator ,field2)
- (,field2 ,separator ,field1))))
+ (,field1 ,separator ,field2)
+ (,field2 ,separator ,field1))))
(sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
(op :field (byte 8 0))
(imm))
;;; A one-byte instruction with a #x66 prefix, used to indicate an
-;;; operand size of :word.
+;;; operand size of :word.
(sb!disassem:define-instruction-format (x66-byte 16
:default-printer '(:name))
(x66 :field (byte 8 0) :value #x66)
;;; Same as simple, but with the immediate value occurring by default,
;;; and with an appropiate printer.
(sb!disassem:define-instruction-format (accum-imm 8
- :include 'simple
- :default-printer '(:name
- :tab accum ", " imm))
+ :include 'simple
+ :default-printer '(:name
+ :tab accum ", " imm))
(imm :type 'signed-imm-data))
(sb!disassem:define-instruction-format (rex-accum-imm 16
- :include 'rex-simple
- :default-printer '(:name
- :tab accum ", " imm))
+ :include 'rex-simple
+ :default-printer '(:name
+ :tab accum ", " imm))
(imm :type 'signed-imm-data))
(sb!disassem:define-instruction-format (reg-no-width 8
- :default-printer '(:name :tab reg))
- (op :field (byte 5 3))
+ :default-printer '(:name :tab reg))
+ (op :field (byte 5 3))
(reg :field (byte 3 0) :type 'reg-b)
;; optional fields
(accum :type 'accum)
(imm))
(sb!disassem:define-instruction-format (rex-reg-no-width 16
- :default-printer '(:name :tab reg))
+ :default-printer '(:name :tab reg))
(rex :field (byte 4 4) :value #b0100)
(wrxb :field (byte 4 0) :type 'wrxb)
- (op :field (byte 5 11))
+ (op :field (byte 5 11))
(reg :field (byte 3 8) :type 'reg-b)
;; optional fields
(accum :type 'accum)
;;; Same as reg-no-width, but with a default operand size of :qword.
(sb!disassem:define-instruction-format (reg-no-width-default-qword 8
- :include 'reg-no-width
+ :include 'reg-no-width
:default-printer '(:name :tab reg))
(reg :type 'reg-b-default-qword))
;;; Same as rex-reg-no-width, but with a default operand size of :qword.
(sb!disassem:define-instruction-format (rex-reg-no-width-default-qword 16
- :include 'rex-reg-no-width
+ :include 'rex-reg-no-width
:default-printer '(:name :tab reg))
(reg :type 'reg-b-default-qword))
(sb!disassem:define-instruction-format (modrm-reg-no-width 24
- :default-printer '(:name :tab reg))
+ :default-printer '(:name :tab reg))
(rex :field (byte 4 4) :value #b0100)
(wrxb :field (byte 4 0) :type 'wrxb)
(ff :field (byte 8 8) :value #b11111111)
- (mod :field (byte 2 22))
+ (mod :field (byte 2 22))
(modrm-reg :field (byte 3 19))
(reg :field (byte 3 16) :type 'reg-b)
;; optional fields
;;; the WIDTH field last, but the prefilter for WIDTH must run before
;;; the one for IMM to be able to determine the correct size of IMM.
(sb!disassem:define-instruction-format (reg 8
- :default-printer '(:name :tab reg))
+ :default-printer '(:name :tab reg))
(op :field (byte 4 4))
(width :field (byte 1 3) :type 'width)
(reg :field (byte 3 0) :type 'reg-b)
(imm))
(sb!disassem:define-instruction-format (rex-reg 16
- :default-printer '(:name :tab reg))
+ :default-printer '(:name :tab reg))
(rex :field (byte 4 4) :value #b0100)
(wrxb :field (byte 4 0) :type 'wrxb)
(width :field (byte 1 11) :type 'width)
(imm))
(sb!disassem:define-instruction-format (two-bytes 16
- :default-printer '(:name))
+ :default-printer '(:name))
(op :fields (list (byte 8 0) (byte 8 8))))
(sb!disassem:define-instruction-format (reg-reg/mem 16
- :default-printer
- `(:name :tab reg ", " reg/mem))
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
(op :field (byte 7 1))
- (width :field (byte 1 0) :type 'width)
+ (width :field (byte 1 0) :type 'width)
(reg/mem :fields (list (byte 2 14) (byte 3 8))
- :type 'reg/mem)
- (reg :field (byte 3 11) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 11) :type 'reg)
;; optional fields
(imm))
(sb!disassem:define-instruction-format (rex-reg-reg/mem 24
- :default-printer
- `(:name :tab reg ", " reg/mem))
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
(rex :field (byte 4 4) :value #b0100)
(wrxb :field (byte 4 0) :type 'wrxb)
- (width :field (byte 1 8) :type 'width)
+ (width :field (byte 1 8) :type 'width)
(op :field (byte 7 9))
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'reg/mem)
- (reg :field (byte 3 19) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 19) :type 'reg)
;; optional fields
(imm))
;;; same as reg-reg/mem, but with direction bit
(sb!disassem:define-instruction-format (reg-reg/mem-dir 16
- :include 'reg-reg/mem
- :default-printer
- `(:name
- :tab
- ,(swap-if 'dir 'reg/mem ", " 'reg)))
+ :include 'reg-reg/mem
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg/mem ", " 'reg)))
(op :field (byte 6 2))
(dir :field (byte 1 1)))
(sb!disassem:define-instruction-format (rex-reg-reg/mem-dir 24
- :include 'rex-reg-reg/mem
- :default-printer
- `(:name
- :tab
- ,(swap-if 'dir 'reg/mem ", " 'reg)))
+ :include 'rex-reg-reg/mem
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg/mem ", " 'reg)))
(op :field (byte 6 10))
(dir :field (byte 1 9)))
;;; Same as reg-reg/mem, but uses the reg field as a second op code.
(sb!disassem:define-instruction-format (reg/mem 16
- :default-printer '(:name :tab reg/mem))
+ :default-printer '(:name :tab reg/mem))
(op :fields (list (byte 7 1) (byte 3 11)))
- (width :field (byte 1 0) :type 'width)
+ (width :field (byte 1 0) :type 'width)
(reg/mem :fields (list (byte 2 14) (byte 3 8))
- :type 'sized-reg/mem)
+ :type 'sized-reg/mem)
;; optional fields
(imm))
(sb!disassem:define-instruction-format (rex-reg/mem 24
- :default-printer '(:name :tab reg/mem))
+ :default-printer '(:name :tab reg/mem))
(rex :field (byte 4 4) :value #b0100)
(wrxb :field (byte 4 0) :type 'wrxb)
(op :fields (list (byte 7 9) (byte 3 19)))
- (width :field (byte 1 8) :type 'width)
+ (width :field (byte 1 8) :type 'width)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
:type 'sized-reg/mem)
;; optional fields
:default-printer '(:name :tab reg/mem))
(op :fields (list (byte 8 0) (byte 3 11)))
(reg/mem :fields (list (byte 2 14) (byte 3 8))
- :type 'sized-reg/mem-default-qword))
+ :type 'sized-reg/mem-default-qword))
(sb!disassem:define-instruction-format (rex-reg/mem-default-qword 24
:default-printer '(:name :tab reg/mem))
;;; Same as reg/mem, but with the immediate value occurring by default,
;;; and with an appropiate printer.
(sb!disassem:define-instruction-format (reg/mem-imm 16
- :include 'reg/mem
- :default-printer
- '(:name :tab reg/mem ", " imm))
+ :include 'reg/mem
+ :default-printer
+ '(:name :tab reg/mem ", " imm))
(reg/mem :type 'sized-reg/mem)
(imm :type 'signed-imm-data))
(sb!disassem:define-instruction-format (rex-reg/mem-imm 24
- :include 'rex-reg/mem
- :default-printer
- '(:name :tab reg/mem ", " imm))
+ :include 'rex-reg/mem
+ :default-printer
+ '(:name :tab reg/mem ", " imm))
(reg/mem :type 'sized-reg/mem)
(imm :type 'signed-imm-data))
(sb!disassem:define-instruction-format
(accum-reg/mem 16
:include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
- (reg/mem :type 'reg/mem) ; don't need a size
+ (reg/mem :type 'reg/mem) ; don't need a size
(accum :type 'accum))
(sb!disassem:define-instruction-format (rex-accum-reg/mem 24
:include 'rex-reg/mem
:default-printer
'(:name :tab accum ", " reg/mem))
- (reg/mem :type 'reg/mem) ; don't need a size
+ (reg/mem :type 'reg/mem) ; don't need a size
(accum :type 'accum))
;;; Same as reg-reg/mem, but with a prefix of #b00001111
(sb!disassem:define-instruction-format (ext-reg-reg/mem 24
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (prefix :field (byte 8 0) :value #b00001111)
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 7 9))
- (width :field (byte 1 8) :type 'width)
+ (width :field (byte 1 8) :type 'width)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'reg/mem)
- (reg :field (byte 3 19) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 19) :type 'reg)
;; optional fields
(imm))
(sb!disassem:define-instruction-format (ext-reg-reg/mem-no-width 24
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (prefix :field (byte 8 0) :value #b00001111)
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 8 8))
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'reg/mem)
- (reg :field (byte 3 19) :type 'reg))
+ :type 'reg/mem)
+ (reg :field (byte 3 19) :type 'reg))
(sb!disassem:define-instruction-format (rex-ext-reg-reg/mem-no-width 32
- :default-printer
- `(:name :tab reg ", " reg/mem))
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
(rex :field (byte 4 4) :value #b0100)
(wrxb :field (byte 4 0) :type 'wrxb)
- (prefix :field (byte 8 8) :value #b00001111)
+ (prefix :field (byte 8 8) :value #b00001111)
(op :field (byte 8 16))
(reg/mem :fields (list (byte 2 30) (byte 3 24))
- :type 'reg/mem)
- (reg :field (byte 3 27) :type 'reg))
+ :type 'reg/mem)
+ (reg :field (byte 3 27) :type 'reg))
;;; Same as reg-reg/mem, but with a prefix of #xf2 0f
(sb!disassem:define-instruction-format (xmm-ext-reg-reg/mem 32
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (prefix :field (byte 8 0) :value #xf2)
- (prefix2 :field (byte 8 8) :value #x0f)
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0) :value #xf2)
+ (prefix2 :field (byte 8 8) :value #x0f)
(op :field (byte 7 17))
- (width :field (byte 1 16) :type 'width)
+ (width :field (byte 1 16) :type 'width)
(reg/mem :fields (list (byte 2 30) (byte 3 24))
- :type 'reg/mem)
- (reg :field (byte 3 27) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 27) :type 'reg)
;; optional fields
(imm))
;;; reg-no-width with #x0f prefix
(sb!disassem:define-instruction-format (ext-reg-no-width 16
- :default-printer '(:name :tab reg))
- (prefix :field (byte 8 0) :value #b00001111)
- (op :field (byte 5 11))
+ :default-printer '(:name :tab reg))
+ (prefix :field (byte 8 0) :value #b00001111)
+ (op :field (byte 5 11))
(reg :field (byte 3 8) :type 'reg-b))
;;; Same as reg/mem, but with a prefix of #b00001111
(sb!disassem:define-instruction-format (ext-reg/mem 24
- :default-printer '(:name :tab reg/mem))
- (prefix :field (byte 8 0) :value #b00001111)
+ :default-printer '(:name :tab reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
(op :fields (list (byte 7 9) (byte 3 19)))
- (width :field (byte 1 8) :type 'width)
+ (width :field (byte 1 8) :type 'width)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'sized-reg/mem)
+ :type 'sized-reg/mem)
;; optional fields
(imm))
(sb!disassem:define-instruction-format (ext-reg/mem-imm 24
:include 'ext-reg/mem
- :default-printer
+ :default-printer
'(:name :tab reg/mem ", " imm))
(imm :type 'signed-imm-data))
\f
;;; regular fp inst to/from registers/memory
(sb!disassem:define-instruction-format (floating-point 16
- :default-printer
- `(:name :tab reg/mem))
+ :default-printer
+ `(:name :tab reg/mem))
(prefix :field (byte 5 3) :value #b11011)
(op :fields (list (byte 3 0) (byte 3 11)))
(reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
;;; fp insn to/from fp reg
(sb!disassem:define-instruction-format (floating-point-fp 16
- :default-printer `(:name :tab fp-reg))
+ :default-printer `(:name :tab fp-reg))
(prefix :field (byte 5 3) :value #b11011)
(suffix :field (byte 2 14) :value #b11)
(op :fields (list (byte 3 0) (byte 3 11)))
;;; (added by (?) pfw)
;;; fp no operand isns
(sb!disassem:define-instruction-format (floating-point-no 16
- :default-printer '(:name))
+ :default-printer '(:name))
(prefix :field (byte 8 0) :value #b11011001)
(suffix :field (byte 3 13) :value #b111)
(op :field (byte 5 8)))
(sb!disassem:define-instruction-format (floating-point-3 16
- :default-printer '(:name))
+ :default-printer '(:name))
(prefix :field (byte 5 3) :value #b11011)
(suffix :field (byte 2 14) :value #b11)
(op :fields (list (byte 3 0) (byte 6 8))))
(sb!disassem:define-instruction-format (floating-point-5 16
- :default-printer '(:name))
+ :default-printer '(:name))
(prefix :field (byte 8 0) :value #b11011011)
(suffix :field (byte 3 13) :value #b111)
(op :field (byte 5 8)))
(sb!disassem:define-instruction-format (floating-point-st 16
- :default-printer '(:name))
+ :default-printer '(:name))
(prefix :field (byte 8 0) :value #b11011111)
(suffix :field (byte 3 13) :value #b111)
(op :field (byte 5 8)))
(sb!disassem:define-instruction-format (string-op 8
- :include 'simple
- :default-printer '(:name width)))
+ :include 'simple
+ :default-printer '(:name width)))
(sb!disassem:define-instruction-format (rex-string-op 16
- :include 'rex-simple
- :default-printer '(:name width)))
+ :include 'rex-simple
+ :default-printer '(:name width)))
(sb!disassem:define-instruction-format (short-cond-jump 16)
(op :field (byte 4 4))
- (cc :field (byte 4 0) :type 'condition-code)
+ (cc :field (byte 4 0) :type 'condition-code)
(label :field (byte 8 8) :type 'displacement))
(sb!disassem:define-instruction-format (short-jump 16
- :default-printer '(:name :tab label))
+ :default-printer '(:name :tab label))
(const :field (byte 4 4) :value #b1110)
- (op :field (byte 4 0))
+ (op :field (byte 4 0))
(label :field (byte 8 8) :type 'displacement))
(sb!disassem:define-instruction-format (near-cond-jump 16)
(op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
- (cc :field (byte 4 8) :type 'condition-code)
+ (cc :field (byte 4 8) :type 'condition-code)
;; The disassembler currently doesn't let you have an instruction > 32 bits
;; long, so we fake it by using a prefilter to read the offset.
(label :type 'displacement
- :prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate))))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
(sb!disassem:define-instruction-format (near-jump 8
- :default-printer '(:name :tab label))
+ :default-printer '(:name :tab label))
(op :field (byte 8 0))
;; The disassembler currently doesn't let you have an instruction > 32 bits
;; long, so we fake it by using a prefilter to read the address.
(label :type 'displacement
- :prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate))))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
(sb!disassem:define-instruction-format (cond-set 24
- :default-printer '('set cc :tab reg/mem))
+ :default-printer '('set cc :tab reg/mem))
(prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 4 12) :value #b1001)
- (cc :field (byte 4 8) :type 'condition-code)
+ (cc :field (byte 4 8) :type 'condition-code)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'sized-byte-reg/mem)
- (reg :field (byte 3 19) :value #b000))
+ :type 'sized-byte-reg/mem)
+ (reg :field (byte 3 19) :value #b000))
(sb!disassem:define-instruction-format (cond-move 24
:default-printer
(reg :field (byte 3 27) :type 'reg))
(sb!disassem:define-instruction-format (enter-format 32
- :default-printer '(:name
- :tab disp
- (:unless (:constant 0)
- ", " level)))
+ :default-printer '(:name
+ :tab disp
+ (:unless (:constant 0)
+ ", " level)))
(op :field (byte 8 0))
(disp :field (byte 16 8))
(level :field (byte 8 24)))
;;; Single byte instruction with an immediate byte argument.
(sb!disassem:define-instruction-format (byte-imm 16
- :default-printer '(:name :tab code))
+ :default-printer '(:name :tab code))
(op :field (byte 8 0))
(code :field (byte 8 8)))
\f
(note-fixup segment (if quad-p :absolute64 :absolute) fixup)
(let ((offset (fixup-offset fixup)))
(if (label-p offset)
- (emit-back-patch segment
- (if quad-p 8 4)
- (lambda (segment posn)
- (declare (ignore posn))
- (let ((val (- (+ (component-header-length)
- (or (label-position offset)
- 0))
- other-pointer-lowtag)))
- (if quad-p
- (emit-qword segment val )
- (emit-dword segment val )))))
- (if quad-p
- (emit-qword segment (or offset 0))
- (emit-dword segment (or offset 0))))))
+ (emit-back-patch segment
+ (if quad-p 8 4)
+ (lambda (segment posn)
+ (declare (ignore posn))
+ (let ((val (- (+ (component-header-length)
+ (or (label-position offset)
+ 0))
+ other-pointer-lowtag)))
+ (if quad-p
+ (emit-qword segment val )
+ (emit-dword segment val )))))
+ (if quad-p
+ (emit-qword segment (or offset 0))
+ (emit-dword segment (or offset 0))))))
(defun emit-relative-fixup (segment fixup)
(note-fixup segment :relative fixup)
;; and up are selected by a REX prefix byte which caller is responsible
;; for having emitted where necessary already
(cond ((fp-reg-tn-p tn)
- (mod (tn-offset tn) 8))
- (t
- (let ((offset (mod (tn-offset tn) 16)))
- (logior (ash (logand offset 1) 2)
- (ash offset -1))))))
-
+ (mod (tn-offset tn) 8))
+ (t
+ (let ((offset (mod (tn-offset tn) 16)))
+ (logior (ash (logand offset 1) 2)
+ (ash offset -1))))))
+
(defstruct (ea (:constructor make-ea (size &key base index scale disp))
- (:copier nil))
+ (:copier nil))
;; note that we can represent an EA with a QWORD size, but EMIT-EA
;; can't actually emit it on its own: caller also needs to emit REX
;; prefix
(disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
(def!method print-object ((ea ea) stream)
(cond ((or *print-escape* *print-readably*)
- (print-unreadable-object (ea stream :type t)
- (format stream
- "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
- (ea-size ea)
- (ea-base ea)
- (ea-index ea)
- (let ((scale (ea-scale ea)))
- (if (= scale 1) nil scale))
- (ea-disp ea))))
- (t
- (format stream "~A PTR [" (symbol-name (ea-size ea)))
- (when (ea-base ea)
- (write-string (sb!c::location-print-name (ea-base ea)) stream)
- (when (ea-index ea)
- (write-string "+" stream)))
- (when (ea-index ea)
- (write-string (sb!c::location-print-name (ea-index ea)) stream))
- (unless (= (ea-scale ea) 1)
- (format stream "*~A" (ea-scale ea)))
- (typecase (ea-disp ea)
- (null)
- (integer
- (format stream "~@D" (ea-disp ea)))
- (t
- (format stream "+~A" (ea-disp ea))))
- (write-char #\] stream))))
+ (print-unreadable-object (ea stream :type t)
+ (format stream
+ "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
+ (ea-size ea)
+ (ea-base ea)
+ (ea-index ea)
+ (let ((scale (ea-scale ea)))
+ (if (= scale 1) nil scale))
+ (ea-disp ea))))
+ (t
+ (format stream "~A PTR [" (symbol-name (ea-size ea)))
+ (when (ea-base ea)
+ (write-string (sb!c::location-print-name (ea-base ea)) stream)
+ (when (ea-index ea)
+ (write-string "+" stream)))
+ (when (ea-index ea)
+ (write-string (sb!c::location-print-name (ea-index ea)) stream))
+ (unless (= (ea-scale ea) 1)
+ (format stream "*~A" (ea-scale ea)))
+ (typecase (ea-disp ea)
+ (null)
+ (integer
+ (format stream "~@D" (ea-disp ea)))
+ (t
+ (format stream "+~A" (ea-disp ea))))
+ (write-char #\] stream))))
(defun emit-constant-tn-rip (segment constant-tn reg)
;; AMD64 doesn't currently have a code object register to use as a
;; that stores the constant. Since we don't know where the code header
;; starts, instead count backwards from the function header.
(let* ((2comp (component-info *component-being-compiled*))
- (constants (ir2-component-constants 2comp))
- (len (length constants))
- ;; Both CODE-HEADER and SIMPLE-FUN-HEADER are 16-byte aligned.
- ;; If there are an even amount of constants, there will be
- ;; an extra qword of padding before the function header, which
- ;; needs to be adjusted for. XXX: This will break if new slots
- ;; are added to the code header.
- (offset (* (- (+ len (if (evenp len)
- 1
- 2))
- (tn-offset constant-tn))
- n-word-bytes)))
+ (constants (ir2-component-constants 2comp))
+ (len (length constants))
+ ;; Both CODE-HEADER and SIMPLE-FUN-HEADER are 16-byte aligned.
+ ;; If there are an even amount of constants, there will be
+ ;; an extra qword of padding before the function header, which
+ ;; needs to be adjusted for. XXX: This will break if new slots
+ ;; are added to the code header.
+ (offset (* (- (+ len (if (evenp len)
+ 1
+ 2))
+ (tn-offset constant-tn))
+ n-word-bytes)))
;; RIP-relative addressing
(emit-mod-reg-r/m-byte segment #b00 reg #b101)
(emit-back-patch segment
- 4
- (lambda (segment posn)
- ;; The addressing is relative to end of instruction,
- ;; i.e. the end of this dword. Hence the + 4.
- (emit-dword segment (+ 4 (- (+ offset posn)))))))
+ 4
+ (lambda (segment posn)
+ ;; The addressing is relative to end of instruction,
+ ;; i.e. the end of this dword. Hence the + 4.
+ (emit-dword segment (+ 4 (- (+ offset posn)))))))
(values))
(defun emit-label-rip (segment fixup reg)
;; RIP-relative addressing
(emit-mod-reg-r/m-byte segment #b00 reg #b101)
(emit-back-patch segment
- 4
- (lambda (segment posn)
- (emit-dword segment (- (label-position label)
- (+ posn 4))))))
+ 4
+ (lambda (segment posn)
+ (emit-dword segment (- (label-position label)
+ (+ posn 4))))))
(values))
(defun emit-ea (segment thing reg &optional allow-constants)
;; an ea given a tn
(ecase (sb-name (sc-sb (tn-sc thing)))
((registers float-registers)
- (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
+ (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
(stack
- ;; Convert stack tns into an index off RBP.
- (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
- (cond ((< -128 disp 127)
- (emit-mod-reg-r/m-byte segment #b01 reg #b101)
- (emit-byte segment disp))
- (t
- (emit-mod-reg-r/m-byte segment #b10 reg #b101)
- (emit-dword segment disp)))))
+ ;; Convert stack tns into an index off RBP.
+ (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
+ (cond ((< -128 disp 127)
+ (emit-mod-reg-r/m-byte segment #b01 reg #b101)
+ (emit-byte segment disp))
+ (t
+ (emit-mod-reg-r/m-byte segment #b10 reg #b101)
+ (emit-dword segment disp)))))
(constant
- (unless allow-constants
- ;; Why?
- (error
- "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
- (emit-constant-tn-rip segment thing reg))))
+ (unless allow-constants
+ ;; Why?
+ (error
+ "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
+ (emit-constant-tn-rip segment thing reg))))
(ea
(let* ((base (ea-base thing))
- (index (ea-index thing))
- (scale (ea-scale thing))
- (disp (ea-disp thing))
- (mod (cond ((or (null base)
- (and (eql disp 0)
- (not (= (reg-tn-encoding base) #b101))))
- #b00)
- ((and (fixnump disp) (<= -128 disp 127))
- #b01)
- (t
- #b10)))
- (r/m (cond (index #b100)
- ((null base) #b101)
- (t (reg-tn-encoding base)))))
+ (index (ea-index thing))
+ (scale (ea-scale thing))
+ (disp (ea-disp thing))
+ (mod (cond ((or (null base)
+ (and (eql disp 0)
+ (not (= (reg-tn-encoding base) #b101))))
+ #b00)
+ ((and (fixnump disp) (<= -128 disp 127))
+ #b01)
+ (t
+ #b10)))
+ (r/m (cond (index #b100)
+ ((null base) #b101)
+ (t (reg-tn-encoding base)))))
(when (and (= mod 0) (= r/m #b101))
- ;; this is rip-relative in amd64, so we'll use a sib instead
- (setf r/m #b100 scale 1))
+ ;; this is rip-relative in amd64, so we'll use a sib instead
+ (setf r/m #b100 scale 1))
(emit-mod-reg-r/m-byte segment mod reg r/m)
(when (= r/m #b100)
- (let ((ss (1- (integer-length scale)))
- (index (if (null index)
- #b100
- (let ((index (reg-tn-encoding index)))
- (if (= index #b100)
- (error "can't index off of ESP")
- index))))
- (base (if (null base)
- #b101
- (reg-tn-encoding base))))
- (emit-sib-byte segment ss index base)))
+ (let ((ss (1- (integer-length scale)))
+ (index (if (null index)
+ #b100
+ (let ((index (reg-tn-encoding index)))
+ (if (= index #b100)
+ (error "can't index off of ESP")
+ index))))
+ (base (if (null base)
+ #b101
+ (reg-tn-encoding base))))
+ (emit-sib-byte segment ss index base)))
(cond ((= mod #b01)
- (emit-byte segment disp))
- ((or (= mod #b10) (null base))
- (if (fixup-p disp)
- (emit-absolute-fixup segment disp)
- (emit-dword segment disp))))))
+ (emit-byte segment disp))
+ ((or (= mod #b10) (null base))
+ (if (fixup-p disp)
+ (emit-absolute-fixup segment disp)
+ (emit-dword segment disp))))))
(fixup
(typecase (fixup-offset thing)
(label
- (emit-label-rip segment thing reg))
+ (emit-label-rip segment thing reg))
(t
- (emit-mod-reg-r/m-byte segment #b00 reg #b100)
- (emit-sib-byte segment 0 #b100 #b101)
- (emit-absolute-fixup segment thing))))))
+ (emit-mod-reg-r/m-byte segment #b00 reg #b100)
+ (emit-sib-byte segment 0 #b100 #b101)
+ (emit-absolute-fixup segment thing))))))
(defun fp-reg-tn-p (thing)
(and (tn-p thing)
(defun emit-fp-op (segment thing op)
(if (fp-reg-tn-p thing)
(emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
- (byte 3 0)
- #b11000000)))
+ (byte 3 0)
+ #b11000000)))
(emit-ea segment thing op)))
(defun byte-reg-p (thing)
(def!constant +operand-size-prefix-byte+ #b01100110)
(defun maybe-emit-operand-size-prefix (segment size)
- (unless (or (eq size :byte)
- (eq size :qword) ; REX prefix handles this
- (eq size +default-operand-size+))
+ (unless (or (eq size :byte)
+ (eq size :qword) ; REX prefix handles this
+ (eq size +default-operand-size+))
(emit-byte segment +operand-size-prefix-byte+)))
;;; A REX prefix must be emitted if at least one of the following
operand-size)
(type (or null tn) r x b))
(labels ((if-hi (r)
- (if (and r (> (tn-offset r)
- ;; offset of r8 is 16, offset of xmm8 is 8
- (if (fp-reg-tn-p r)
- 7
- 15)))
- 1
- 0))
+ (if (and r (> (tn-offset r)
+ ;; offset of r8 is 16, offset of xmm8 is 8
+ (if (fp-reg-tn-p r)
+ 7
+ 15)))
+ 1
+ 0))
(reg-4-7-p (r)
;; Assuming R is a TN describing a general purpose
;; register, return true if it references register
;; 4 upto 7.
(<= 8 (tn-offset r) 15)))
(let ((rex-w (if (eq operand-size :qword) 1 0))
- (rex-r (if-hi r))
- (rex-x (if-hi x))
- (rex-b (if-hi b)))
+ (rex-r (if-hi r))
+ (rex-x (if-hi x))
+ (rex-b (if-hi b)))
(when (or (not (zerop (logior rex-w rex-r rex-x rex-b)))
(and r
(eq operand-size :byte)
(and b
(eq (operand-size b) :byte)
(reg-4-7-p b)))
- (emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))
+ (emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))
;;; Emit a REX prefix if necessary. The operand size is determined from
;;; THING or can be overwritten by OPERAND-SIZE. This and REG are always
operand-size))
(let ((ea-p (ea-p thing)))
(maybe-emit-rex-prefix segment
- (or operand-size (operand-size thing))
- reg
- (and ea-p (ea-index thing))
- (cond (ea-p (ea-base thing))
- ((and (tn-p thing)
- (member (sb-name (sc-sb (tn-sc thing)))
- '(float-registers registers)))
- thing)
- (t nil)))))
+ (or operand-size (operand-size thing))
+ reg
+ (and ea-p (ea-index thing))
+ (cond (ea-p (ea-base thing))
+ ((and (tn-p thing)
+ (member (sb-name (sc-sb (tn-sc thing)))
+ '(float-registers registers)))
+ thing)
+ (t nil)))))
(defun operand-size (thing)
(typecase thing
;; to hack up the code
(case (sc-name (tn-sc thing))
(#.*qword-sc-names*
- :qword)
+ :qword)
(#.*dword-sc-names*
- :dword)
+ :dword)
(#.*word-sc-names*
- :word)
+ :word)
(#.*byte-sc-names*
- :byte)
+ :byte)
;; added by jrd: float-registers is a separate size (?)
(#.*float-sc-names*
- :float)
+ :float)
(#.*double-sc-names*
- :double)
+ :double)
(t
- (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
+ (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
(ea
(ea-size thing))
(fixup
(defun matching-operand-size (dst src)
(let ((dst-size (operand-size dst))
- (src-size (operand-size src)))
+ (src-size (operand-size src)))
(if dst-size
- (if src-size
- (if (eq dst-size src-size)
- dst-size
- (error "size mismatch: ~S is a ~S and ~S is a ~S."
- dst dst-size src src-size))
- dst-size)
- (if src-size
- src-size
- (error "can't tell the size of either ~S or ~S" dst src)))))
+ (if src-size
+ (if (eq dst-size src-size)
+ dst-size
+ (error "size mismatch: ~S is a ~S and ~S is a ~S."
+ dst dst-size src src-size))
+ dst-size)
+ (if src-size
+ src-size
+ (error "can't tell the size of either ~S or ~S" dst src)))))
(defun emit-sized-immediate (segment size value &optional quad-p)
(ecase size
;; dword data bytes even when 64 bit work is being done. So, mostly
;; we treat quad constants as dwords.
(if (and quad-p (eq size :qword))
- (emit-qword segment value)
- (emit-dword segment value)))))
+ (emit-qword segment value)
+ (emit-dword segment value)))))
\f
;;;; general data transfer
(define-instruction mov (segment dst src)
;; immediate to register
(:printer reg ((op #b1011) (imm nil :type 'signed-imm-data))
- '(:name :tab reg ", " imm))
+ '(:name :tab reg ", " imm))
(:printer rex-reg ((op #b1011) (imm nil :type 'signed-imm-data-upto-qword))
- '(:name :tab reg ", " imm))
+ '(:name :tab reg ", " imm))
;; absolute mem to/from accumulator
(:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
- `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
+ `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
;; register to/from register/memory
(:printer reg-reg/mem-dir ((op #b100010)))
(:printer rex-reg-reg/mem-dir ((op #b100010)))
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond ((register-p dst)
- (cond ((integerp src)
- (maybe-emit-rex-prefix segment size nil nil dst)
- (emit-byte-with-reg segment
- (if (eq size :byte)
- #b10110
- #b10111)
- (reg-tn-encoding dst))
- (emit-sized-immediate segment size src (eq size :qword)))
- (t
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment
- (if (eq size :byte)
- #b10001010
- #b10001011))
- (emit-ea segment src (reg-tn-encoding dst) t))))
- ((integerp src)
- ;; C7 only deals with 32 bit immediates even if register is
- ;; 64 bit: only b8-bf use 64 bit immediates
- (maybe-emit-rex-for-ea segment dst nil)
- (cond ((typep src '(or (signed-byte 32) (unsigned-byte 32)))
- (emit-byte segment
- (if (eq size :byte) #b11000110 #b11000111))
- (emit-ea segment dst #b000)
- (emit-sized-immediate segment
- (case size (:qword :dword) (t size))
- src))
- (t
- (aver nil))))
- ((register-p src)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
- (emit-ea segment dst (reg-tn-encoding src)))
- ((fixup-p src)
- ;; Generally we can't MOV a fixupped value into an EA, since
- ;; MOV on non-registers can only take a 32-bit immediate arg.
- ;; Make an exception for :FOREIGN fixups (pretty much just
- ;; the runtime asm, since other foreign calls go through the
- ;; the linkage table) and for linkage table references, since
- ;; these should always end up in low memory.
- (aver (or (eq (fixup-flavor src) :foreign)
- (eq (fixup-flavor src) :foreign-dataref)
- (eq (ea-size dst) :dword)))
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment #b11000111)
- (emit-ea segment dst #b000)
- (emit-absolute-fixup segment src))
- (t
- (error "bogus arguments to MOV: ~S ~S" dst src))))))
+ (cond ((integerp src)
+ (maybe-emit-rex-prefix segment size nil nil dst)
+ (emit-byte-with-reg segment
+ (if (eq size :byte)
+ #b10110
+ #b10111)
+ (reg-tn-encoding dst))
+ (emit-sized-immediate segment size src (eq size :qword)))
+ (t
+ (maybe-emit-rex-for-ea segment src dst)
+ (emit-byte segment
+ (if (eq size :byte)
+ #b10001010
+ #b10001011))
+ (emit-ea segment src (reg-tn-encoding dst) t))))
+ ((integerp src)
+ ;; C7 only deals with 32 bit immediates even if register is
+ ;; 64 bit: only b8-bf use 64 bit immediates
+ (maybe-emit-rex-for-ea segment dst nil)
+ (cond ((typep src '(or (signed-byte 32) (unsigned-byte 32)))
+ (emit-byte segment
+ (if (eq size :byte) #b11000110 #b11000111))
+ (emit-ea segment dst #b000)
+ (emit-sized-immediate segment
+ (case size (:qword :dword) (t size))
+ src))
+ (t
+ (aver nil))))
+ ((register-p src)
+ (maybe-emit-rex-for-ea segment dst src)
+ (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
+ (emit-ea segment dst (reg-tn-encoding src)))
+ ((fixup-p src)
+ ;; Generally we can't MOV a fixupped value into an EA, since
+ ;; MOV on non-registers can only take a 32-bit immediate arg.
+ ;; Make an exception for :FOREIGN fixups (pretty much just
+ ;; the runtime asm, since other foreign calls go through the
+ ;; the linkage table) and for linkage table references, since
+ ;; these should always end up in low memory.
+ (aver (or (eq (fixup-flavor src) :foreign)
+ (eq (fixup-flavor src) :foreign-dataref)
+ (eq (ea-size dst) :dword)))
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment #b11000111)
+ (emit-ea segment dst #b000)
+ (emit-absolute-fixup segment src))
+ (t
+ (error "bogus arguments to MOV: ~S ~S" dst src))))))
(defun emit-move-with-extension (segment dst src signed-p)
(aver (register-p dst))
(let ((dst-size (operand-size dst))
- (src-size (operand-size src))
- (opcode (if signed-p #b10111110 #b10110110)))
+ (src-size (operand-size src))
+ (opcode (if signed-p #b10111110 #b10110110)))
(ecase dst-size
(:word
(aver (eq src-size :byte))
(emit-ea segment src (reg-tn-encoding dst)))
((:dword :qword)
(ecase src-size
- (:byte
- (maybe-emit-rex-for-ea segment src dst :operand-size dst-size)
- (emit-byte segment #b00001111)
- (emit-byte segment opcode)
- (emit-ea segment src (reg-tn-encoding dst)))
- (:word
- (maybe-emit-rex-for-ea segment src dst :operand-size dst-size)
- (emit-byte segment #b00001111)
- (emit-byte segment (logior opcode 1))
- (emit-ea segment src (reg-tn-encoding dst)))
- (:dword
- (aver (eq dst-size :qword))
- ;; dst is in reg, src is in modrm
- (let ((ea-p (ea-p src)))
- (maybe-emit-rex-prefix segment (if signed-p :qword :dword) dst
- (and ea-p (ea-index src))
- (cond (ea-p (ea-base src))
- ((tn-p src) src)
- (t nil)))
- (emit-byte segment #x63) ;movsxd
- ;;(emit-byte segment opcode)
- (emit-ea segment src (reg-tn-encoding dst)))))))))
+ (:byte
+ (maybe-emit-rex-for-ea segment src dst :operand-size dst-size)
+ (emit-byte segment #b00001111)
+ (emit-byte segment opcode)
+ (emit-ea segment src (reg-tn-encoding dst)))
+ (:word
+ (maybe-emit-rex-for-ea segment src dst :operand-size dst-size)
+ (emit-byte segment #b00001111)
+ (emit-byte segment (logior opcode 1))
+ (emit-ea segment src (reg-tn-encoding dst)))
+ (:dword
+ (aver (eq dst-size :qword))
+ ;; dst is in reg, src is in modrm
+ (let ((ea-p (ea-p src)))
+ (maybe-emit-rex-prefix segment (if signed-p :qword :dword) dst
+ (and ea-p (ea-index src))
+ (cond (ea-p (ea-base src))
+ ((tn-p src) src)
+ (t nil)))
+ (emit-byte segment #x63) ;movsxd
+ ;;(emit-byte segment opcode)
+ (emit-ea segment src (reg-tn-encoding dst)))))))))
(define-instruction movsx (segment dst src)
(:printer ext-reg-reg/mem-no-width
(:printer rex-reg/mem-default-qword ((op '(#b11111111 #b110))))
;; immediate
(:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
- '(:name :tab imm))
+ '(:name :tab imm))
(:printer byte ((op #b01101000)
(imm nil :type 'signed-imm-data-default-qword))
- '(:name :tab imm))
+ '(:name :tab imm))
;; ### segment registers?
(:emitter
(cond ((integerp src)
- (cond ((<= -128 src 127)
- (emit-byte segment #b01101010)
- (emit-byte segment src))
- (t
- ;; A REX-prefix is not needed because the operand size
- ;; defaults to 64 bits. The size of the immediate is 32
- ;; bits and it is sign-extended.
- (emit-byte segment #b01101000)
- (emit-dword segment src))))
- (t
- (let ((size (operand-size src)))
- (aver (not (eq size :byte)))
- (maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment src nil :operand-size :do-not-set)
- (cond ((register-p src)
- (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
- (t
- (emit-byte segment #b11111111)
- (emit-ea segment src #b110 t))))))))
+ (cond ((<= -128 src 127)
+ (emit-byte segment #b01101010)
+ (emit-byte segment src))
+ (t
+ ;; A REX-prefix is not needed because the operand size
+ ;; defaults to 64 bits. The size of the immediate is 32
+ ;; bits and it is sign-extended.
+ (emit-byte segment #b01101000)
+ (emit-dword segment src))))
+ (t
+ (let ((size (operand-size src)))
+ (aver (not (eq size :byte)))
+ (maybe-emit-operand-size-prefix segment size)
+ (maybe-emit-rex-for-ea segment src nil :operand-size :do-not-set)
+ (cond ((register-p src)
+ (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
+ (t
+ (emit-byte segment #b11111111)
+ (emit-ea segment src #b110 t))))))))
(define-instruction pop (segment dst)
(:printer reg-no-width-default-qword ((op #b01011)))
(maybe-emit-operand-size-prefix segment size)
(maybe-emit-rex-for-ea segment dst nil :operand-size :do-not-set)
(cond ((register-p dst)
- (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
- (t
- (emit-byte segment #b10001111)
- (emit-ea segment dst #b000))))))
+ (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
+ (t
+ (emit-byte segment #b10001111)
+ (emit-ea segment dst #b000))))))
(define-instruction xchg (segment operand1 operand2)
;; Register with accumulator.
(let ((size (matching-operand-size operand1 operand2)))
(maybe-emit-operand-size-prefix segment size)
(labels ((xchg-acc-with-something (acc something)
- (if (and (not (eq size :byte)) (register-p something))
- (progn
- (maybe-emit-rex-for-ea segment acc something)
- (emit-byte-with-reg segment
- #b10010
- (reg-tn-encoding something)))
- (xchg-reg-with-something acc something)))
- (xchg-reg-with-something (reg something)
- (maybe-emit-rex-for-ea segment something reg)
- (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
- (emit-ea segment something (reg-tn-encoding reg))))
+ (if (and (not (eq size :byte)) (register-p something))
+ (progn
+ (maybe-emit-rex-for-ea segment acc something)
+ (emit-byte-with-reg segment
+ #b10010
+ (reg-tn-encoding something)))
+ (xchg-reg-with-something acc something)))
+ (xchg-reg-with-something (reg something)
+ (maybe-emit-rex-for-ea segment something reg)
+ (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
+ (emit-ea segment something (reg-tn-encoding reg))))
(cond ((accumulator-p operand1)
- (xchg-acc-with-something operand1 operand2))
- ((accumulator-p operand2)
- (xchg-acc-with-something operand2 operand1))
- ((register-p operand1)
- (xchg-reg-with-something operand1 operand2))
- ((register-p operand2)
- (xchg-reg-with-something operand2 operand1))
- (t
- (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
+ (xchg-acc-with-something operand1 operand2))
+ ((accumulator-p operand2)
+ (xchg-acc-with-something operand2 operand1))
+ ((register-p operand1)
+ (xchg-reg-with-something operand1 operand2))
+ ((register-p operand2)
+ (xchg-reg-with-something operand2 operand1))
+ (t
+ (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
(define-instruction lea (segment dst src)
(:printer rex-reg-reg/mem ((op #b1000110)))
(:emitter
(aver (or (dword-reg-p dst) (qword-reg-p dst)))
(maybe-emit-rex-for-ea segment src dst
- :operand-size :qword)
+ :operand-size :qword)
(emit-byte segment #b10001101)
(emit-ea segment src (reg-tn-encoding dst))))
;;;; arithmetic
(defun emit-random-arith-inst (name segment dst src opcode
- &optional allow-constants)
+ &optional allow-constants)
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond
((integerp src)
(cond ((and (not (eq size :byte)) (<= -128 src 127))
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment #b10000011)
- (emit-ea segment dst opcode allow-constants)
- (emit-byte segment src))
- ((accumulator-p dst)
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment
- (dpb opcode
- (byte 3 3)
- (if (eq size :byte)
- #b00000100
- #b00000101)))
- (emit-sized-immediate segment size src))
- (t
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
- (emit-ea segment dst opcode allow-constants)
- (emit-sized-immediate segment size src))))
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment #b10000011)
+ (emit-ea segment dst opcode allow-constants)
+ (emit-byte segment src))
+ ((accumulator-p dst)
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte)
+ #b00000100
+ #b00000101)))
+ (emit-sized-immediate segment size src))
+ (t
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
+ (emit-ea segment dst opcode allow-constants)
+ (emit-sized-immediate segment size src))))
((register-p src)
(maybe-emit-rex-for-ea segment dst src)
(emit-byte segment
- (dpb opcode
- (byte 3 3)
- (if (eq size :byte) #b00000000 #b00000001)))
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000000 #b00000001)))
(emit-ea segment dst (reg-tn-encoding src) allow-constants))
((register-p dst)
(maybe-emit-rex-for-ea segment src dst)
(emit-byte segment
- (dpb opcode
- (byte 3 3)
- (if (eq size :byte) #b00000010 #b00000011)))
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000010 #b00000011)))
(emit-ea segment src (reg-tn-encoding dst) allow-constants))
(t
(error "bogus operands to ~A" name)))))
;; The redundant encoding #x82 is invalid in 64-bit mode,
;; therefore we force WIDTH to 1.
(reg/mem-imm ((op (#b1000001 ,subop)) (width 1)
- (imm nil :type signed-imm-byte)))
+ (imm nil :type signed-imm-byte)))
(rex-reg/mem-imm ((op (#b1000001 ,subop)) (width 1)
(imm nil :type signed-imm-byte)))
(reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))
(let ((size (operand-size dst)))
(maybe-emit-operand-size-prefix segment size)
(cond #+nil ; these opcodes become REX prefixes in x86-64
- ((and (not (eq size :byte)) (register-p dst))
- (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
- (t
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
- (emit-ea segment dst #b000))))))
+ ((and (not (eq size :byte)) (register-p dst))
+ (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
+ (t
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+ (emit-ea segment dst #b000))))))
(define-instruction dec (segment dst)
;; Register.
(let ((size (operand-size dst)))
(maybe-emit-operand-size-prefix segment size)
(cond #+nil
- ((and (not (eq size :byte)) (register-p dst))
- (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
- (t
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
- (emit-ea segment dst #b001))))))
+ ((and (not (eq size :byte)) (register-p dst))
+ (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
+ (t
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+ (emit-ea segment dst #b001))))))
(define-instruction neg (segment dst)
(:printer reg/mem ((op '(#b1111011 #b011))))
(:printer rex-ext-reg-reg/mem-no-width ((op #b10101111)))
(:printer reg-reg/mem ((op #b0110100) (width 1)
(imm nil :type 'signed-imm-data))
- '(:name :tab reg ", " reg/mem ", " imm))
+ '(:name :tab reg ", " reg/mem ", " imm))
(:printer rex-reg-reg/mem ((op #b0110100) (width 1)
(imm nil :type 'signed-imm-data))
- '(:name :tab reg ", " reg/mem ", " imm))
+ '(:name :tab reg ", " reg/mem ", " imm))
(:printer reg-reg/mem ((op #b0110101) (width 1)
- (imm nil :type 'signed-imm-byte))
- '(:name :tab reg ", " reg/mem ", " imm))
+ (imm nil :type 'signed-imm-byte))
+ '(:name :tab reg ", " reg/mem ", " imm))
(:printer rex-reg-reg/mem ((op #b0110101) (width 1)
(imm nil :type 'signed-imm-byte))
- '(:name :tab reg ", " reg/mem ", " imm))
+ '(:name :tab reg ", " reg/mem ", " imm))
(:emitter
(flet ((r/m-with-immed-to-reg (reg r/m immed)
- (let* ((size (matching-operand-size reg r/m))
- (sx (and (not (eq size :byte)) (<= -128 immed 127))))
- (maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment r/m reg)
- (emit-byte segment (if sx #b01101011 #b01101001))
- (emit-ea segment r/m (reg-tn-encoding reg))
- (if sx
- (emit-byte segment immed)
- (emit-sized-immediate segment size immed)))))
+ (let* ((size (matching-operand-size reg r/m))
+ (sx (and (not (eq size :byte)) (<= -128 immed 127))))
+ (maybe-emit-operand-size-prefix segment size)
+ (maybe-emit-rex-for-ea segment r/m reg)
+ (emit-byte segment (if sx #b01101011 #b01101001))
+ (emit-ea segment r/m (reg-tn-encoding reg))
+ (if sx
+ (emit-byte segment immed)
+ (emit-sized-immediate segment size immed)))))
(cond (src2
- (r/m-with-immed-to-reg dst src1 src2))
- (src1
- (if (integerp src1)
- (r/m-with-immed-to-reg dst dst src1)
- (let ((size (matching-operand-size dst src1)))
- (maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment src1 dst)
- (emit-byte segment #b00001111)
- (emit-byte segment #b10101111)
- (emit-ea segment src1 (reg-tn-encoding dst)))))
- (t
- (let ((size (operand-size dst)))
- (maybe-emit-operand-size-prefix segment size)
- (maybe-emit-rex-for-ea segment dst nil)
- (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
- (emit-ea segment dst #b101)))))))
+ (r/m-with-immed-to-reg dst src1 src2))
+ (src1
+ (if (integerp src1)
+ (r/m-with-immed-to-reg dst dst src1)
+ (let ((size (matching-operand-size dst src1)))
+ (maybe-emit-operand-size-prefix segment size)
+ (maybe-emit-rex-for-ea segment src1 dst)
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b10101111)
+ (emit-ea segment src1 (reg-tn-encoding dst)))))
+ (t
+ (let ((size (operand-size dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (maybe-emit-rex-for-ea segment dst nil)
+ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment dst #b101)))))))
(define-instruction div (segment dst src)
(:printer accum-reg/mem ((op '(#b1111011 #b110))))
(let ((size (operand-size dst)))
(maybe-emit-operand-size-prefix segment size)
(multiple-value-bind (major-opcode immed)
- (case amount
- (:cl (values #b11010010 nil))
- (1 (values #b11010000 nil))
- (t (values #b11000000 t)))
+ (case amount
+ (:cl (values #b11010010 nil))
+ (1 (values #b11010000 nil))
+ (t (values #b11000000 t)))
(maybe-emit-rex-for-ea segment dst nil)
(emit-byte segment
- (if (eq size :byte) major-opcode (logior major-opcode 1)))
+ (if (eq size :byte) major-opcode (logior major-opcode 1)))
(emit-ea segment dst opcode)
(when immed
- (emit-byte segment amount)))))
+ (emit-byte segment amount)))))
(eval-when (:compile-toplevel :execute)
(defun shift-inst-printer-list (subop)
`((reg/mem ((op (#b1101000 ,subop)))
- (:name :tab reg/mem ", 1"))
+ (:name :tab reg/mem ", 1"))
(rex-reg/mem ((op (#b1101000 ,subop)))
- (:name :tab reg/mem ", 1"))
+ (:name :tab reg/mem ", 1"))
(reg/mem ((op (#b1101001 ,subop)))
- (:name :tab reg/mem ", " 'cl))
+ (:name :tab reg/mem ", " 'cl))
(rex-reg/mem ((op (#b1101001 ,subop)))
- (:name :tab reg/mem ", " 'cl))
+ (:name :tab reg/mem ", " 'cl))
(reg/mem-imm ((op (#b1100000 ,subop))
- (imm nil :type imm-byte)))
+ (imm nil :type imm-byte)))
(rex-reg/mem-imm ((op (#b1100000 ,subop))
- (imm nil :type imm-byte))))))
+ (imm nil :type imm-byte))))))
(define-instruction rol (segment dst amount)
(:printer-list
(maybe-emit-rex-for-ea segment dst src)
(emit-byte segment #b00001111)
(emit-byte segment (dpb opcode (byte 1 3)
- (if (eq amt :cl) #b10100101 #b10100100)))
- (emit-ea segment dst (reg-tn-encoding src))
+ (if (eq amt :cl) #b10100101 #b10100100)))
+ (emit-ea segment dst (reg-tn-encoding src))
(unless (eq amt :cl)
(emit-byte segment amt))))
(defun double-shift-inst-printer-list (op)
`(#+nil
(ext-reg-reg/mem-imm ((op ,(logior op #b100))
- (imm nil :type signed-imm-byte)))
+ (imm nil :type signed-imm-byte)))
(ext-reg-reg/mem ((op ,(logior op #b101)))
- (:name :tab reg/mem ", " 'cl)))))
+ (:name :tab reg/mem ", " 'cl)))))
(define-instruction shld (segment dst src amt)
(:declare (type (or (member :cl) (mod 32)) amt))
(let ((size (matching-operand-size this that)))
(maybe-emit-operand-size-prefix segment size)
(flet ((test-immed-and-something (immed something)
- (cond ((accumulator-p something)
- (maybe-emit-rex-for-ea segment something nil)
- (emit-byte segment
- (if (eq size :byte) #b10101000 #b10101001))
- (emit-sized-immediate segment size immed))
- (t
- (maybe-emit-rex-for-ea segment something nil)
- (emit-byte segment
- (if (eq size :byte) #b11110110 #b11110111))
- (emit-ea segment something #b000)
- (emit-sized-immediate segment size immed))))
- (test-reg-and-something (reg something)
- (maybe-emit-rex-for-ea segment something reg)
- (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
- (emit-ea segment something (reg-tn-encoding reg))))
+ (cond ((accumulator-p something)
+ (maybe-emit-rex-for-ea segment something nil)
+ (emit-byte segment
+ (if (eq size :byte) #b10101000 #b10101001))
+ (emit-sized-immediate segment size immed))
+ (t
+ (maybe-emit-rex-for-ea segment something nil)
+ (emit-byte segment
+ (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment something #b000)
+ (emit-sized-immediate segment size immed))))
+ (test-reg-and-something (reg something)
+ (maybe-emit-rex-for-ea segment something reg)
+ (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
+ (emit-ea segment something (reg-tn-encoding reg))))
(cond ((integerp that)
- (test-immed-and-something that this))
- ((integerp this)
- (test-immed-and-something this that))
- ((register-p this)
- (test-reg-and-something this that))
- ((register-p that)
- (test-reg-and-something that this))
- (t
- (error "bogus operands for TEST: ~S and ~S" this that)))))))
+ (test-immed-and-something that this))
+ ((integerp this)
+ (test-immed-and-something this that))
+ ((register-p this)
+ (test-reg-and-something this that))
+ ((register-p that)
+ (test-reg-and-something that this))
+ (t
+ (error "bogus operands for TEST: ~S and ~S" this that)))))))
(define-instruction or (segment dst src)
(:printer-list
(error "can't scan bytes: ~S" src))
(maybe-emit-operand-size-prefix segment size)
(cond ((integerp index)
- (maybe-emit-rex-for-ea segment src nil)
- (emit-byte segment #b00001111)
- (emit-byte segment #b10111010)
- (emit-ea segment src opcode)
- (emit-byte segment index))
- (t
- (maybe-emit-rex-for-ea segment src index)
- (emit-byte segment #b00001111)
- (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
- (emit-ea segment src (reg-tn-encoding index))))))
+ (maybe-emit-rex-for-ea segment src nil)
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b10111010)
+ (emit-ea segment src opcode)
+ (emit-byte segment index))
+ (t
+ (maybe-emit-rex-for-ea segment src index)
+ (emit-byte segment #b00001111)
+ (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
+ (emit-ea segment src (reg-tn-encoding index))))))
(eval-when (:compile-toplevel :execute)
(defun bit-test-inst-printer-list (subop)
(label
(emit-byte segment #b11101000) ; 32 bit relative
(emit-back-patch segment
- 4
- (lambda (segment posn)
- (emit-dword segment
- (- (label-position where)
- (+ posn 4))))))
+ 4
+ (lambda (segment posn)
+ (emit-dword segment
+ (- (label-position where)
+ (+ posn 4))))))
(fixup
(emit-byte segment #b11101000)
(emit-relative-fixup segment where))
(defun emit-byte-displacement-backpatch (segment target)
(emit-back-patch segment
- 1
- (lambda (segment posn)
- (let ((disp (- (label-position target) (1+ posn))))
- (aver (<= -128 disp 127))
- (emit-byte segment disp)))))
+ 1
+ (lambda (segment posn)
+ (let ((disp (- (label-position target) (1+ posn))))
+ (aver (<= -128 disp 127))
+ (emit-byte segment disp)))))
(define-instruction jmp (segment cond &optional where)
;; conditional jumps
(:printer rex-reg/mem-default-qword ((op '(#b11111111 #b100))))
(:emitter
(cond (where
- (emit-chooser
- segment 6 2
- (lambda (segment posn delta-if-after)
- (let ((disp (- (label-position where posn delta-if-after)
- (+ posn 2))))
- (when (<= -128 disp 127)
- (emit-byte segment
- (dpb (conditional-opcode cond)
- (byte 4 0)
- #b01110000))
- (emit-byte-displacement-backpatch segment where)
- t)))
- (lambda (segment posn)
- (let ((disp (- (label-position where) (+ posn 6))))
- (emit-byte segment #b00001111)
- (emit-byte segment
- (dpb (conditional-opcode cond)
- (byte 4 0)
- #b10000000))
- (emit-dword segment disp)))))
- ((label-p (setq where cond))
- (emit-chooser
- segment 5 0
- (lambda (segment posn delta-if-after)
- (let ((disp (- (label-position where posn delta-if-after)
- (+ posn 2))))
- (when (<= -128 disp 127)
- (emit-byte segment #b11101011)
- (emit-byte-displacement-backpatch segment where)
- t)))
- (lambda (segment posn)
- (let ((disp (- (label-position where) (+ posn 5))))
- (emit-byte segment #b11101001)
- (emit-dword segment disp)))))
- ((fixup-p where)
- (emit-byte segment #b11101001)
- (emit-relative-fixup segment where))
- (t
- (unless (or (ea-p where) (tn-p where))
- (error "don't know what to do with ~A" where))
- ;; near jump defaults to 64 bit
- ;; w-bit in rex prefix is unnecessary
- (maybe-emit-rex-for-ea segment where nil :operand-size :do-not-set)
- (emit-byte segment #b11111111)
- (emit-ea segment where #b100)))))
+ (emit-chooser
+ segment 6 2
+ (lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
+ (emit-byte segment
+ (dpb (conditional-opcode cond)
+ (byte 4 0)
+ #b01110000))
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ (lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 6))))
+ (emit-byte segment #b00001111)
+ (emit-byte segment
+ (dpb (conditional-opcode cond)
+ (byte 4 0)
+ #b10000000))
+ (emit-dword segment disp)))))
+ ((label-p (setq where cond))
+ (emit-chooser
+ segment 5 0
+ (lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
+ (emit-byte segment #b11101011)
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ (lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 5))))
+ (emit-byte segment #b11101001)
+ (emit-dword segment disp)))))
+ ((fixup-p where)
+ (emit-byte segment #b11101001)
+ (emit-relative-fixup segment where))
+ (t
+ (unless (or (ea-p where) (tn-p where))
+ (error "don't know what to do with ~A" where))
+ ;; near jump defaults to 64 bit
+ ;; w-bit in rex prefix is unnecessary
+ (maybe-emit-rex-for-ea segment where nil :operand-size :do-not-set)
+ (emit-byte segment #b11111111)
+ (emit-ea segment where #b100)))))
(define-instruction jmp-short (segment label)
(:emitter
(define-instruction ret (segment &optional stack-delta)
(:printer byte ((op #b11000011)))
(:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
- '(:name :tab imm))
+ '(:name :tab imm))
(:emitter
(cond (stack-delta
- (emit-byte segment #b11000010)
- (emit-word segment stack-delta))
- (t
- (emit-byte segment #b11000011)))))
+ (emit-byte segment #b11000010)
+ (emit-word segment stack-delta))
+ (t
+ (emit-byte segment #b11000011)))))
(define-instruction jecxz (segment target)
(:printer short-jump ((op #b0011)))
(define-instruction loop (segment target)
(:printer short-jump ((op #b0010)))
(:emitter
- (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
+ (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
(emit-byte-displacement-backpatch segment target)))
(define-instruction loopz (segment target)
(define-instruction enter (segment disp &optional (level 0))
(:declare (type (unsigned-byte 16) disp)
- (type (unsigned-byte 8) level))
+ (type (unsigned-byte 8) level))
(:printer enter-format ((op #b11001000)))
(:emitter
(emit-byte segment #b11001000)
(defun snarf-error-junk (sap offset &optional length-only)
(let* ((length (sb!sys:sap-ref-8 sap offset))
- (vector (make-array length :element-type '(unsigned-byte 8))))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
(declare (type sb!sys:system-area-pointer sap)
- (type (unsigned-byte 8) length)
- (type (simple-array (unsigned-byte 8) (*)) vector))
+ (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
(cond (length-only
- (values 0 (1+ length) nil nil))
- (t
- (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
+ (values 0 (1+ length) nil nil))
+ (t
+ (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
vector 0 length)
- (collect ((sc-offsets)
- (lengths))
- (lengths 1) ; the length byte
- (let* ((index 0)
- (error-number (sb!c:read-var-integer vector index)))
- (lengths index)
- (loop
- (when (>= index length)
- (return))
- (let ((old-index index))
- (sc-offsets (sb!c:read-var-integer vector index))
- (lengths (- index old-index))))
- (values error-number
- (1+ length)
- (sc-offsets)
- (lengths))))))))
+ (collect ((sc-offsets)
+ (lengths))
+ (lengths 1) ; the length byte
+ (let* ((index 0)
+ (error-number (sb!c:read-var-integer vector index)))
+ (lengths index)
+ (loop
+ (when (>= index length)
+ (return))
+ (let ((old-index index))
+ (sc-offsets (sb!c:read-var-integer vector index))
+ (lengths (- index old-index))))
+ (values error-number
+ (1+ length)
+ (sc-offsets)
+ (lengths))))))))
#|
(defmacro break-cases (breaknum &body cases)
(let ((bn-temp (gensym)))
(collect ((clauses))
(dolist (case cases)
- (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
+ (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
`(let ((,bn-temp ,breaknum))
- (cond ,@(clauses))))))
+ (cond ,@(clauses))))))
|#
(defun break-control (chunk inst stream dstate)
(define-instruction break (segment code)
(:declare (type (unsigned-byte 8) code))
(:printer byte-imm ((op #b11001100)) '(:name :tab code)
- :control #'break-control)
+ :control #'break-control)
(:emitter
(emit-byte segment #b11001100)
(emit-byte segment code)))
(defun emit-header-data (segment type)
(emit-back-patch segment
- n-word-bytes
- (lambda (segment posn)
- (emit-qword segment
- (logior type
- (ash (+ posn
- (component-header-length))
- (- n-widetag-bits
- word-shift)))))))
+ n-word-bytes
+ (lambda (segment posn)
+ (emit-qword segment
+ (logior type
+ (ash (+ posn
+ (component-header-length))
+ (- n-widetag-bits
+ word-shift)))))))
(define-instruction simple-fun-header-word (segment)
(:emitter
(:printer floating-point ((op '(#b001 #b000))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011001)
(emit-fp-op segment source #b000)))
(if (fp-reg-tn-p source)
(emit-byte segment #b11011001)
(progn
- (maybe-emit-rex-for-ea segment source nil)
- (emit-byte segment #b11011101)))
+ (maybe-emit-rex-for-ea segment source nil)
+ (emit-byte segment #b11011101)))
(emit-fp-op segment source #b000)))
;;; Load long to st(0).
(:printer floating-point ((op '(#b011 #b101))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011011)
(emit-fp-op segment source #b101)))
(:printer floating-point ((op '(#b001 #b010))))
(:emitter
(cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b010))
- (t
- (maybe-emit-rex-for-ea segment dest nil)
- (emit-byte segment #b11011001)
- (emit-fp-op segment dest #b010)))))
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b010))
+ (t
+ (maybe-emit-rex-for-ea segment dest nil)
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment dest #b010)))))
;;; Store double from st(0).
(define-instruction fstd (segment dest)
(:printer floating-point-fp ((op '(#b101 #b010))))
(:emitter
(cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b010))
- (t
- (maybe-emit-rex-for-ea segment dest nil)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b010)))))
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b010))
+ (t
+ (maybe-emit-rex-for-ea segment dest nil)
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b010)))))
;;; Arithmetic ops are all done with at least one operand at top of
;;; stack. The other operand is is another register or a 32/64 bit
(:printer floating-point ((op '(#b000 #b000))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011000)
(emit-fp-op segment source #b000)))
(:printer floating-point-fp ((op '(#b000 #b000))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(if (fp-reg-tn-p source)
(emit-byte segment #b11011000)
(emit-byte segment #b11011100))
(:printer floating-point ((op '(#b000 #b100))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011000)
(emit-fp-op segment source #b100)))
(:printer floating-point ((op '(#b000 #b101))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011000)
(emit-fp-op segment source #b101)))
(if (fp-reg-tn-p source)
(emit-byte segment #b11011000)
(progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
+ (and (not (fp-reg-tn-p source))
+ (maybe-emit-rex-for-ea segment source nil))
+ (emit-byte segment #b11011100)))
(emit-fp-op segment source #b100)))
;;; Subtract double, reverse:
(if (fp-reg-tn-p source)
(emit-byte segment #b11011000)
(progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
+ (and (not (fp-reg-tn-p source))
+ (maybe-emit-rex-for-ea segment source nil))
+ (emit-byte segment #b11011100)))
(emit-fp-op segment source #b101)))
;;; Subtract double, destination st(i):
(:printer floating-point ((op '(#b000 #b001))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011000)
(emit-fp-op segment source #b001)))
(if (fp-reg-tn-p source)
(emit-byte segment #b11011000)
(progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
+ (and (not (fp-reg-tn-p source))
+ (maybe-emit-rex-for-ea segment source nil))
+ (emit-byte segment #b11011100)))
(emit-fp-op segment source #b001)))
;;; Multiply double, destination st(i):
(:printer floating-point ((op '(#b000 #b110))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011000)
(emit-fp-op segment source #b110)))
(:printer floating-point ((op '(#b000 #b111))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011000)
(emit-fp-op segment source #b111)))
(if (fp-reg-tn-p source)
(emit-byte segment #b11011000)
(progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
+ (and (not (fp-reg-tn-p source))
+ (maybe-emit-rex-for-ea segment source nil))
+ (emit-byte segment #b11011100)))
(emit-fp-op segment source #b110)))
;;; Divide double, reverse:
(:emitter
(if (fp-reg-tn-p source)
(emit-byte segment #b11011000)
- (progn
- (and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
- (emit-byte segment #b11011100)))
+ (progn
+ (and (not (fp-reg-tn-p source))
+ (maybe-emit-rex-for-ea segment source nil))
+ (emit-byte segment #b11011100)))
(emit-fp-op segment source #b111)))
;;; Divide double, destination st(i):
(:printer floating-point-fp ((op '(#b001 #b001))))
(:emitter
(unless (and (tn-p source)
- (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
+ (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
(cl:break))
(emit-byte segment #b11011001)
(emit-fp-op segment source #b001)))
(:printer floating-point ((op '(#b011 #b000))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011011)
(emit-fp-op segment source #b000)))
(:printer floating-point ((op '(#b111 #b101))))
(:emitter
(and (not (fp-reg-tn-p source))
- (maybe-emit-rex-for-ea segment source nil))
+ (maybe-emit-rex-for-ea segment source nil))
(emit-byte segment #b11011111)
(emit-fp-op segment source #b101)))
(:printer floating-point ((op '(#b011 #b010))))
(:emitter
(and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
+ (maybe-emit-rex-for-ea segment dest nil))
(emit-byte segment #b11011011)
(emit-fp-op segment dest #b010)))
(:printer floating-point ((op '(#b011 #b011))))
(:emitter
(and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
+ (maybe-emit-rex-for-ea segment dest nil))
(emit-byte segment #b11011011)
(emit-fp-op segment dest #b011)))
(:printer floating-point ((op '(#b111 #b111))))
(:emitter
(and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
+ (maybe-emit-rex-for-ea segment dest nil))
(emit-byte segment #b11011111)
(emit-fp-op segment dest #b111)))
(:printer floating-point ((op '(#b001 #b011))))
(:emitter
(cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b011))
- (t
- (maybe-emit-rex-for-ea segment dest nil)
- (emit-byte segment #b11011001)
- (emit-fp-op segment dest #b011)))))
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b011))
+ (t
+ (maybe-emit-rex-for-ea segment dest nil)
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment dest #b011)))))
;;; Store double from st(0) and pop.
(define-instruction fstpd (segment dest)
(:printer floating-point-fp ((op '(#b101 #b011))))
(:emitter
(cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b011))
- (t
- (maybe-emit-rex-for-ea segment dest nil)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b011)))))
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b011))
+ (t
+ (maybe-emit-rex-for-ea segment dest nil)
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b011)))))
;;; Store long from st(0) and pop.
(define-instruction fstpl (segment dest)
(:printer floating-point ((op '(#b011 #b111))))
(:emitter
(and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
+ (maybe-emit-rex-for-ea segment dest nil))
(emit-byte segment #b11011011)
(emit-fp-op segment dest #b111)))
(:printer floating-point-fp ((op '(#b101 #b000))))
(:emitter
(and (not (fp-reg-tn-p dest))
- (maybe-emit-rex-for-ea segment dest nil))
+ (maybe-emit-rex-for-ea segment dest nil))
(emit-byte segment #b11011101)
(emit-fp-op segment dest #b000)))
(:printer floating-point ((op '(#b001 #b101))))
(:emitter
(and (not (fp-reg-tn-p src))
- (maybe-emit-rex-for-ea segment src nil))
+ (maybe-emit-rex-for-ea segment src nil))
(emit-byte segment #b11011001)
(emit-fp-op segment src #b101)))
(:printer floating-point ((op '(#b001 #b111))))
(:emitter
(and (not (fp-reg-tn-p dst))
- (maybe-emit-rex-for-ea segment dst nil))
+ (maybe-emit-rex-for-ea segment dst nil))
(emit-byte segment #b11011001)
(emit-fp-op segment dst #b111)))
(:printer floating-point ((op '(#b001 #b110))))
(:emitter
(and (not (fp-reg-tn-p dst))
- (maybe-emit-rex-for-ea segment dst nil))
+ (maybe-emit-rex-for-ea segment dst nil))
(emit-byte segment #b11011001)
(emit-fp-op segment dst #b110)))
(:printer floating-point ((op '(#b001 #b100))))
(:emitter
(and (not (fp-reg-tn-p src))
- (maybe-emit-rex-for-ea segment src nil))
+ (maybe-emit-rex-for-ea segment src nil))
(emit-byte segment #b11011001)
(emit-fp-op segment src #b100)))
(:printer floating-point ((op '(#b101 #b110))))
(:emitter
(and (not (fp-reg-tn-p dst))
- (maybe-emit-rex-for-ea segment dst nil))
+ (maybe-emit-rex-for-ea segment dst nil))
(emit-byte segment #b11011101)
(emit-fp-op segment dst #b110)))
(:printer floating-point ((op '(#b101 #b100))))
(:emitter
(and (not (fp-reg-tn-p src))
- (maybe-emit-rex-for-ea segment src nil))
+ (maybe-emit-rex-for-ea segment src nil))
(emit-byte segment #b11011101)
(emit-fp-op segment src #b100)))
(:printer floating-point ((op '(#b000 #b010))))
(:emitter
(and (not (fp-reg-tn-p src))
- (maybe-emit-rex-for-ea segment src nil))
+ (maybe-emit-rex-for-ea segment src nil))
(emit-byte segment #b11011000)
(emit-fp-op segment src #b010)))
(if (fp-reg-tn-p src)
(emit-byte segment #b11011000)
(progn
- (maybe-emit-rex-for-ea segment src nil)
- (emit-byte segment #b11011100)))
+ (maybe-emit-rex-for-ea segment src nil)
+ (emit-byte segment #b11011100)))
(emit-fp-op segment src #b010)))
;;; Compare ST1 to ST0, popping the stack twice.
;;; in any VOPs that use them. See the book.
;;; st0 <- st1*log2(st0)
-(define-instruction fyl2x(segment) ; pops stack
+(define-instruction fyl2x(segment) ; pops stack
(:printer floating-point-no ((op #b10001)))
(:emitter
(emit-byte segment #b11011001)
(emit-byte segment #b11011001)
(emit-byte segment #b11110000)))
-(define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
+(define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
(:printer floating-point-no ((op #b10010)))
(:emitter
(emit-byte segment #b11011001)
(emit-byte segment #b11110010)))
-(define-instruction fpatan(segment) ; POPS STACK
+(define-instruction fpatan(segment) ; POPS STACK
(:printer floating-point-no ((op #b10011)))
(:emitter
(emit-byte segment #b11011001)
(emit-byte segment #b11011001)
(emit-byte segment #b11101101)))
-;; new xmm insns required by sse float
+;; new xmm insns required by sse float
;; movsd andpd comisd comiss
(define-instruction movsd (segment dst src)
; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
(:emitter
- (cond ((typep src 'tn)
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment #x0f)
- (emit-byte segment #x11)
- (emit-ea segment dst (reg-tn-encoding src)))
- (t
- (emit-byte segment #xf2)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x10)
- (emit-ea segment src (reg-tn-encoding dst))))))
+ (cond ((typep src 'tn)
+ (emit-byte segment #xf2)
+ (maybe-emit-rex-for-ea segment dst src)
+ (emit-byte segment #x0f)
+ (emit-byte segment #x11)
+ (emit-ea segment dst (reg-tn-encoding src)))
+ (t
+ (emit-byte segment #xf2)
+ (maybe-emit-rex-for-ea segment src dst)
+ (emit-byte segment #x0f)
+ (emit-byte segment #x10)
+ (emit-ea segment src (reg-tn-encoding dst))))))
(define-instruction movss (segment dst src)
; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
(:emitter
(cond ((tn-p src)
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment #x0f)
- (emit-byte segment #x11)
- (emit-ea segment dst (reg-tn-encoding src)))
- (t
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x10)
- (emit-ea segment src (reg-tn-encoding dst))))))
+ (emit-byte segment #xf3)
+ (maybe-emit-rex-for-ea segment dst src)
+ (emit-byte segment #x0f)
+ (emit-byte segment #x11)
+ (emit-ea segment dst (reg-tn-encoding src)))
+ (t
+ (emit-byte segment #xf3)
+ (maybe-emit-rex-for-ea segment src dst)
+ (emit-byte segment #x0f)
+ (emit-byte segment #x10)
+ (emit-ea segment src (reg-tn-encoding dst))))))
(define-instruction andpd (segment dst src)
; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
(:emitter
(cond ((fp-reg-tn-p dst)
- (emit-byte segment #x66)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x6e)
- (emit-ea segment src (reg-tn-encoding dst)))
- (t
- (aver (fp-reg-tn-p src))
- (emit-byte segment #x66)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment #x0f)
- (emit-byte segment #x7e)
- (emit-ea segment dst (reg-tn-encoding src))))))
+ (emit-byte segment #x66)
+ (maybe-emit-rex-for-ea segment src dst)
+ (emit-byte segment #x0f)
+ (emit-byte segment #x6e)
+ (emit-ea segment src (reg-tn-encoding dst)))
+ (t
+ (aver (fp-reg-tn-p src))
+ (emit-byte segment #x66)
+ (maybe-emit-rex-for-ea segment dst src)
+ (emit-byte segment #x0f)
+ (emit-byte segment #x7e)
+ (emit-ea segment dst (reg-tn-encoding src))))))
(define-instruction movq (segment dst src)
; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
(:emitter
(cond ((fp-reg-tn-p dst)
- (emit-byte segment #xf3)
- (maybe-emit-rex-for-ea segment src dst)
- (emit-byte segment #x0f)
- (emit-byte segment #x7e)
- (emit-ea segment src (reg-tn-encoding dst)))
- (t
- (aver (fp-reg-tn-p src))
- (emit-byte segment #x66)
- (maybe-emit-rex-for-ea segment dst src)
- (emit-byte segment #x0f)
- (emit-byte segment #xd6)
- (emit-ea segment dst (reg-tn-encoding src))))))
+ (emit-byte segment #xf3)
+ (maybe-emit-rex-for-ea segment src dst)
+ (emit-byte segment #x0f)
+ (emit-byte segment #x7e)
+ (emit-ea segment src (reg-tn-encoding dst)))
+ (t
+ (aver (fp-reg-tn-p src))
+ (emit-byte segment #x66)
+ (maybe-emit-rex-for-ea segment dst src)
+ (emit-byte segment #x0f)
+ (emit-byte segment #xd6)
+ (emit-ea segment dst (reg-tn-encoding src))))))
(define-instruction xorpd (segment dst src)
; (:printer reg-reg/mem ((op #x10) (width 1))) ;wrong
(emit-byte segment #x0f)
(emit-byte segment #xae)
(emit-ea segment src 2)))
-
+
(define-instruction stmxcsr (segment dst)
(:emitter
(emit-byte segment #x0f)
#!+sb-doc
"Move SRC into DST unless they are location=."
(once-only ((n-dst dst)
- (n-src src))
+ (n-src src))
`(unless (location= ,n-dst ,n-src)
(inst mov ,n-dst ,n-src))))
(defmacro storew (value ptr &optional (slot 0) (lowtag 0))
(once-only ((value value))
- `(cond ((and (integerp ,value)
- (not (typep ,value '(signed-byte 32))))
- (multiple-value-bind (lo hi) (dwords-for-quad ,value)
- (inst mov (make-ea-for-object-slot-half
- ,ptr ,slot ,lowtag) lo)
- (inst mov (make-ea-for-object-slot-half
- ,ptr (+ ,slot 1/2) ,lowtag) hi)))
- (t
- (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))))
+ `(cond ((and (integerp ,value)
+ (not (typep ,value '(signed-byte 32))))
+ (multiple-value-bind (lo hi) (dwords-for-quad ,value)
+ (inst mov (make-ea-for-object-slot-half
+ ,ptr ,slot ,lowtag) lo)
+ (inst mov (make-ea-for-object-slot-half
+ ,ptr (+ ,slot 1/2) ,lowtag) hi)))
+ (t
+ (inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))))
(defmacro pushw (ptr &optional (slot 0) (lowtag 0))
`(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
(defmacro load-symbol-value (reg symbol)
`(inst mov ,reg
- (make-ea :qword
- :disp (+ nil-value
- (static-symbol-offset ',symbol)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))))
+ (make-ea :qword
+ :disp (+ nil-value
+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))))
(defmacro store-symbol-value (reg symbol)
`(inst mov
- (make-ea :qword
- :disp (+ nil-value
- (static-symbol-offset ',symbol)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))
- ,reg))
+ (make-ea :qword
+ :disp (+ nil-value
+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
+ ,reg))
#!+sb-thread
(defmacro load-tl-symbol-value (reg symbol)
(inst mov ,reg
(make-ea :qword
:disp (+ nil-value
- (static-symbol-offset ',symbol)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
(inst mov ,reg (make-ea :qword :base thread-base-tn :scale 1 :index ,reg))))
#!-sb-thread
(defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
(inst mov ,temp
(make-ea :qword
:disp (+ nil-value
- (static-symbol-offset ',symbol)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
(inst mov (make-ea :qword :base thread-base-tn :scale 1 :index ,temp) ,reg)))
#!-sb-thread
(defmacro store-tl-symbol-value (reg symbol temp)
(declare (ignore temp))
`(store-symbol-value ,reg ,symbol))
-
+
(defmacro load-type (target source &optional (offset 0))
#!+sb-doc
"Loads the type bits of a pointer into target independent of
byte-ordering issues."
(once-only ((n-target target)
- (n-source source)
- (n-offset offset))
+ (n-source source)
+ (n-offset offset))
(ecase *backend-byte-order*
(:little-endian
`(inst mov ,n-target
- (make-ea :byte :base ,n-source :disp ,n-offset)))
+ (make-ea :byte :base ,n-source :disp ,n-offset)))
(:big-endian
`(inst mov ,n-target
- (make-ea :byte :base ,n-source :disp (+ ,n-offset 4)))))))
+ (make-ea :byte :base ,n-source :disp (+ ,n-offset 4)))))))
\f
;;;; allocation helpers
(declare (ignore ignored))
(inst push size)
(inst lea r13-tn (make-ea :qword
- :disp (make-fixup "alloc_tramp" :foreign)))
+ :disp (make-fixup "alloc_tramp" :foreign)))
(inst call r13-tn)
(inst pop alloc-tn)
(values))
(allocation-dynamic-extent alloc-tn size)
(return-from allocation (values)))
(let ((NOT-INLINE (gen-label))
- (DONE (gen-label))
- ;; Yuck.
- (in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
+ (DONE (gen-label))
+ ;; Yuck.
+ (in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
;; thread->alloc_region.free_pointer
- (free-pointer
- #!+sb-thread
- (make-ea :qword
- :base thread-base-tn :scale 1
- :disp (* n-word-bytes thread-alloc-region-slot))
- #!-sb-thread
- (make-ea :qword
- :scale 1 :disp
- (make-fixup (extern-alien-name "boxed_region") :foreign)))
- ;; thread->alloc_region.end_addr
- (end-addr
- #!+sb-thread
- (make-ea :qword
- :base thread-base-tn :scale 1
- :disp (* n-word-bytes (1+ thread-alloc-region-slot)))
- #!-sb-thread
- (make-ea :qword
- :scale 1 :disp
- (make-fixup (extern-alien-name "boxed_region") :foreign 8))))
+ (free-pointer
+ #!+sb-thread
+ (make-ea :qword
+ :base thread-base-tn :scale 1
+ :disp (* n-word-bytes thread-alloc-region-slot))
+ #!-sb-thread
+ (make-ea :qword
+ :scale 1 :disp
+ (make-fixup (extern-alien-name "boxed_region") :foreign)))
+ ;; thread->alloc_region.end_addr
+ (end-addr
+ #!+sb-thread
+ (make-ea :qword
+ :base thread-base-tn :scale 1
+ :disp (* n-word-bytes (1+ thread-alloc-region-slot)))
+ #!-sb-thread
+ (make-ea :qword
+ :scale 1 :disp
+ (make-fixup (extern-alien-name "boxed_region") :foreign 8))))
(cond (in-elsewhere
- (allocation-tramp alloc-tn size))
- (t
- (unless (and (tn-p size) (location= alloc-tn size))
- (inst mov alloc-tn size))
- (inst add alloc-tn free-pointer)
- (inst cmp end-addr alloc-tn)
- (inst jmp :be NOT-INLINE)
- (inst xchg free-pointer alloc-tn)
- (emit-label DONE)
- (assemble (*elsewhere*)
- (emit-label NOT-INLINE)
- (cond ((numberp size)
- (allocation-tramp alloc-tn size))
- (t
- (inst sub alloc-tn free-pointer)
- (allocation-tramp alloc-tn alloc-tn)))
- (inst jmp DONE))
- (values)))))
+ (allocation-tramp alloc-tn size))
+ (t
+ (unless (and (tn-p size) (location= alloc-tn size))
+ (inst mov alloc-tn size))
+ (inst add alloc-tn free-pointer)
+ (inst cmp end-addr alloc-tn)
+ (inst jmp :be NOT-INLINE)
+ (inst xchg free-pointer alloc-tn)
+ (emit-label DONE)
+ (assemble (*elsewhere*)
+ (emit-label NOT-INLINE)
+ (cond ((numberp size)
+ (allocation-tramp alloc-tn size))
+ (t
+ (inst sub alloc-tn free-pointer)
+ (allocation-tramp alloc-tn alloc-tn)))
+ (inst jmp DONE))
+ (values)))))
#+nil
(defun allocation (alloc-tn size &optional ignored)
(declare (ignore ignored))
(inst push size)
(inst lea r13-tn (make-ea :qword
- :disp (make-fixup "alloc_tramp" :foreign)))
+ :disp (make-fixup "alloc_tramp" :foreign)))
(inst call r13-tn)
(inst pop alloc-tn)
(values))
;;; header having the specified WIDETAG value. The result is placed in
;;; RESULT-TN.
(defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
- &body forms)
+ &body forms)
(unless forms
(bug "empty &body in WITH-FIXED-ALLOCATION"))
(once-only ((result-tn result-tn) (size size))
`(pseudo-atomic
(allocation ,result-tn (pad-data-block ,size) ,inline)
(storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
- ,result-tn)
+ ,result-tn)
(inst lea ,result-tn
- (make-ea :qword :base ,result-tn :disp other-pointer-lowtag))
+ (make-ea :qword :base ,result-tn :disp other-pointer-lowtag))
,@forms)))
\f
;;;; error code
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
- `((inst int 3) ; i386 breakpoint instruction
- ;; The return PC points here; note the location for the debugger.
- (let ((vop ,vop))
- (when vop
- (note-this-location vop :internal-error)))
- (inst byte ,kind) ; eg trap_Xyyy
- (with-adjustable-vector (,vector) ; interr arguments
- (write-var-integer (error-number-or-lose ',code) ,vector)
- ,@(mapcar (lambda (tn)
- `(let ((tn ,tn))
- ;; classic CMU CL comment:
- ;; zzzzz jrd here. tn-offset is zero for constant
- ;; tns.
- (write-var-integer (make-sc-offset (sc-number
- (tn-sc tn))
- (or (tn-offset tn)
- 0))
- ,vector)))
- values)
- (inst byte (length ,vector))
- (dotimes (i (length ,vector))
- (inst byte (aref ,vector i))))))))
+ `((inst int 3) ; i386 breakpoint instruction
+ ;; The return PC points here; note the location for the debugger.
+ (let ((vop ,vop))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst byte ,kind) ; eg trap_Xyyy
+ (with-adjustable-vector (,vector) ; interr arguments
+ (write-var-integer (error-number-or-lose ',code) ,vector)
+ ,@(mapcar (lambda (tn)
+ `(let ((tn ,tn))
+ ;; classic CMU CL comment:
+ ;; zzzzz jrd here. tn-offset is zero for constant
+ ;; tns.
+ (write-var-integer (make-sc-offset (sc-number
+ (tn-sc tn))
+ (or (tn-offset tn)
+ 0))
+ ,vector)))
+ values)
+ (inst byte (length ,vector))
+ (dotimes (i (length ,vector))
+ (inst byte (aref ,vector i))))))))
(defmacro error-call (vop error-code &rest values)
#!+sb-doc
"Cause an error. ERROR-CODE is the error to cause."
(cons 'progn
- (emit-error-break vop error-trap error-code values)))
+ (emit-error-break vop error-trap error-code values)))
(defmacro generate-error-code (vop error-code &rest values)
#!+sb-doc
;;; around. It's an operation which the AOP weenies would describe as
;;; having "cross-cutting concerns", meaning it appears all over the
;;; place and there's no logical single place to attach documentation.
-;;; grep (mostly in src/runtime) is your friend
+;;; grep (mostly in src/runtime) is your friend
;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
(with-unique-names (label)
`(let ((,label (gen-label)))
(inst mov (make-ea :byte
- :base thread-base-tn
- :disp (* 8 thread-pseudo-atomic-interrupted-slot)) 0)
+ :base thread-base-tn
+ :disp (* 8 thread-pseudo-atomic-interrupted-slot)) 0)
(inst mov (make-ea :byte
- :base thread-base-tn
- :disp (* 8 thread-pseudo-atomic-atomic-slot))
- (fixnumize 1))
+ :base thread-base-tn
+ :disp (* 8 thread-pseudo-atomic-atomic-slot))
+ (fixnumize 1))
,@forms
- (inst mov (make-ea :byte
- :base thread-base-tn
- :disp (* 8 thread-pseudo-atomic-atomic-slot)) 0)
+ (inst mov (make-ea :byte
+ :base thread-base-tn
+ :disp (* 8 thread-pseudo-atomic-atomic-slot)) 0)
(inst cmp (make-ea :byte
:base thread-base-tn
- :disp (* 8 thread-pseudo-atomic-interrupted-slot)) 0)
+ :disp (* 8 thread-pseudo-atomic-interrupted-slot)) 0)
(inst jmp :eq ,label)
;; if PAI was set, interrupts were disabled at the same
;; time using the process signal mask.
0)
(inst jmp :eq ,label)
;; if PAI was set, interrupts were disabled at the same time
- ;; using the process signal mask.
+ ;; using the process signal mask.
(inst break pending-interrupt-trap)
(emit-label ,label))))
`(progn
(define-vop (,name)
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types ,type tagged-num)
(:results (value :scs ,scs))
(:result-types ,el-type)
- (:generator 3 ; pw was 5
- (inst mov value (make-ea :qword :base object :index index
- :disp (- (* ,offset n-word-bytes)
- ,lowtag)))))
+ (:generator 3 ; pw was 5
+ (inst mov value (make-ea :qword :base object :index index
+ :disp (- (* ,offset n-word-bytes)
+ ,lowtag)))))
(define-vop (,(symbolicate name "-C"))
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:info index)
(:arg-types ,type
- (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
- ,(eval offset))))
+ (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
+ ,(eval offset))))
(:results (value :scs ,scs))
(:result-types ,el-type)
- (:generator 2 ; pw was 5
- (inst mov value (make-ea :qword :base object
- :disp (- (* (+ ,offset index) n-word-bytes)
- ,lowtag)))))))
+ (:generator 2 ; pw was 5
+ (inst mov value (make-ea :qword :base object
+ :disp (- (* (+ ,offset index) n-word-bytes)
+ ,lowtag)))))))
(defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
`(progn
(define-vop (,name)
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs ,scs :target result))
+ (index :scs (any-reg))
+ (value :scs ,scs :target result))
(:arg-types ,type tagged-num ,el-type)
(:results (result :scs ,scs))
(:result-types ,el-type)
- (:generator 4 ; was 5
- (inst mov (make-ea :qword :base object :index index
- :disp (- (* ,offset n-word-bytes) ,lowtag))
- value)
- (move result value)))
+ (:generator 4 ; was 5
+ (inst mov (make-ea :qword :base object :index index
+ :disp (- (* ,offset n-word-bytes) ,lowtag))
+ value)
+ (move result value)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs ,scs :target result))
+ (value :scs ,scs :target result))
(:info index)
(:arg-types ,type
- (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
- ,(eval offset)))
- ,el-type)
+ (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
+ ,(eval offset)))
+ ,el-type)
(:results (result :scs ,scs))
(:result-types ,el-type)
- (:generator 3 ; was 5
- (inst mov (make-ea :qword :base object
- :disp (- (* (+ ,offset index) n-word-bytes)
- ,lowtag))
- value)
- (move result value)))))
+ (:generator 3 ; was 5
+ (inst mov (make-ea :qword :base object
+ :disp (- (* (+ ,offset index) n-word-bytes)
+ ,lowtag))
+ value)
+ (move result value)))))
;;; helper for alien stuff.
(defmacro with-pinned-objects ((&rest objects) &body body)
garbage collection"
`(multiple-value-prog1
(progn
- ,@(loop for p in objects
- collect `(push-word-on-c-stack
- (int-sap (sb!kernel:get-lisp-obj-address ,p))))
- ,@body)
+ ,@(loop for p in objects
+ collect `(push-word-on-c-stack
+ (int-sap (sb!kernel:get-lisp-obj-address ,p))))
+ ,@body)
;; If the body returned normally, we should restore the stack pointer
;; for the benefit of any following code in the same function. If
;; there's a non-local exit in the body, sp is garbage anyway and
(loadw value object offset lowtag)))
(define-vop (cell-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
+ (value :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 4
(storew value object offset lowtag)))
(define-vop (cell-setf)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg) :target result))
+ (value :scs (descriptor-reg any-reg) :target result))
(:results (result :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(move result value)))
(define-vop (cell-setf-fun)
(:args (value :scs (descriptor-reg any-reg) :target result)
- (object :scs (descriptor-reg)))
+ (object :scs (descriptor-reg)))
(:results (result :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
;;; name is NIL, then that operation isn't defined. If the translate
;;; function is null, then we don't define a translation.
(defmacro define-cell-accessors (offset lowtag
- ref-op ref-trans set-op set-trans)
+ ref-op ref-trans set-op set-trans)
`(progn
,@(when ref-op
- `((define-vop (,ref-op cell-ref)
- (:variant ,offset ,lowtag)
- ,@(when ref-trans
- `((:translate ,ref-trans))))))
+ `((define-vop (,ref-op cell-ref)
+ (:variant ,offset ,lowtag)
+ ,@(when ref-trans
+ `((:translate ,ref-trans))))))
,@(when set-op
- `((define-vop (,set-op cell-setf)
- (:variant ,offset ,lowtag)
- ,@(when set-trans
- `((:translate ,set-trans))))))))
+ `((define-vop (,set-op cell-setf)
+ (:variant ,offset ,lowtag)
+ ,@(when set-trans
+ `((:translate ,set-trans))))))))
;;; X86 special
(define-vop (cell-xadd)
(:args (object :scs (descriptor-reg) :to :result)
- (value :scs (any-reg) :target result))
+ (value :scs (any-reg) :target result))
(:results (result :scs (any-reg) :from (:argument 1)))
(:result-types tagged-num)
(:variant-vars offset lowtag)
(:generator 4
(move result value)
(inst xadd (make-ea :dword :base object
- :disp (- (* offset n-word-bytes) lowtag))
- value)))
+ :disp (- (* offset n-word-bytes) lowtag))
+ value)))
;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF,
;;; where the offset is constant at compile time, but varies for
(loadw value object (+ base offset) lowtag)))
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg immediate)))
+ (value :scs (descriptor-reg any-reg immediate)))
(:temporary (:sc unsigned-reg) temp)
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(if (sc-is value immediate)
- (let ((val (tn-value value)))
- (move-immediate (make-ea :qword :base object
- :disp (- (* (+ base offset) n-word-bytes)
- lowtag))
- (etypecase val
- (integer
- (fixnumize val))
- (symbol
- (+ nil-value (static-symbol-offset val)))
- (character
- (logior (ash (char-code val) n-widetag-bits)
- character-widetag)))
- temp))
- ;; Else, value not immediate.
- (storew value object (+ base offset) lowtag))))
+ (let ((val (tn-value value)))
+ (move-immediate (make-ea :qword :base object
+ :disp (- (* (+ base offset) n-word-bytes)
+ lowtag))
+ (etypecase val
+ (integer
+ (fixnumize val))
+ (symbol
+ (+ nil-value (static-symbol-offset val)))
+ (character
+ (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)))
+ temp))
+ ;; Else, value not immediate.
+ (storew value object (+ base offset) lowtag))))
(define-vop (slot-set-conditional)
(:args (object :scs (descriptor-reg) :to :eval)
- (old-value :scs (descriptor-reg any-reg) :target eax)
- (new-value :scs (descriptor-reg any-reg) :target temp))
+ (old-value :scs (descriptor-reg any-reg) :target eax)
+ (new-value :scs (descriptor-reg any-reg) :target temp))
(:temporary (:sc descriptor-reg :offset eax-offset
- :from (:argument 1) :to :result :target result) eax)
+ :from (:argument 1) :to :result :target result) eax)
(:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp)
(:variant-vars base lowtag)
(:results (result :scs (descriptor-reg)))
(move eax old-value)
(move temp new-value)
(inst cmpxchg (make-ea :dword :base object
- :disp (- (* (+ base offset) n-word-bytes) lowtag))
- temp)
+ :disp (- (* (+ base offset) n-word-bytes) lowtag))
+ temp)
(move result eax)))
;;; X86 special
(define-vop (slot-xadd)
(:args (object :scs (descriptor-reg) :to :result)
- (value :scs (any-reg) :target result))
+ (value :scs (any-reg) :target result))
(:results (result :scs (any-reg) :from (:argument 1)))
(:result-types tagged-num)
(:variant-vars base lowtag)
(:generator 4
(move result value)
(inst xadd (make-ea :dword :base object
- :disp (- (* (+ base offset) n-word-bytes) lowtag))
- value)))
+ :disp (- (* (+ base offset) n-word-bytes) lowtag))
+ value)))
(etypecase val
(integer
(if (zerop val)
- (inst xor y y)
- (inst mov y (fixnumize val))))
+ (inst xor y y)
+ (inst mov y (fixnumize val))))
(symbol
(load-symbol y val))
(character
(inst mov y (logior (ash (char-code val) n-widetag-bits)
- character-widetag))))))
+ character-widetag))))))
(define-move-fun (load-number 1) (vop x y)
((immediate) (signed-reg unsigned-reg))
;;;; the MOVE VOP
(define-vop (move)
(:args (x :scs (any-reg descriptor-reg immediate) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (any-reg descriptor-reg)
- :load-if
- (not (or (location= x y)
- (and (sc-is x any-reg descriptor-reg immediate)
- (sc-is y control-stack))))))
+ :load-if
+ (not (or (location= x y)
+ (and (sc-is x any-reg descriptor-reg immediate)
+ (sc-is y control-stack))))))
(:temporary (:sc unsigned-reg) temp)
(:effects)
(:affected)
(:generator 0
(if (and (sc-is x immediate)
- (sc-is y any-reg descriptor-reg control-stack))
- (let ((val (tn-value x)))
- (etypecase val
- (integer
- (if (and (zerop val) (sc-is y any-reg descriptor-reg))
- (inst xor y y)
- (move-immediate y (fixnumize val) temp)))
- (symbol
- (inst mov y (+ nil-value (static-symbol-offset val))))
- (character
- (inst mov y (logior (ash (char-code val) n-widetag-bits)
- character-widetag)))))
- (move y x))))
+ (sc-is y any-reg descriptor-reg control-stack))
+ (let ((val (tn-value x)))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+ (inst xor y y)
+ (move-immediate y (fixnumize val) temp)))
+ (symbol
+ (inst mov y (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst mov y (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)))))
+ (move y x))))
(define-move-vop move :move
(any-reg descriptor-reg immediate)
(cond
;; If target is a register, we can just mov it there directly
((and (tn-p target)
- (sc-is target signed-reg unsigned-reg descriptor-reg any-reg))
+ (sc-is target signed-reg unsigned-reg descriptor-reg any-reg))
(inst mov target val))
;; Likewise if the value is small enough.
((typep val '(signed-byte 31))
;;; this case the loading works out.
(define-vop (move-arg)
(:args (x :scs (any-reg descriptor-reg immediate) :target y
- :load-if (not (and (sc-is y any-reg descriptor-reg)
- (sc-is x control-stack))))
- (fp :scs (any-reg)
- :load-if (not (sc-is y any-reg descriptor-reg))))
+ :load-if (not (and (sc-is y any-reg descriptor-reg)
+ (sc-is x control-stack))))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y any-reg descriptor-reg))))
(:results (y))
(:generator 0
(sc-case y
((any-reg descriptor-reg)
(if (sc-is x immediate)
- (let ((val (tn-value x)))
- (etypecase val
- ((integer 0 0)
- (inst xor y y))
- ((or (signed-byte 29) (unsigned-byte 29))
- (inst mov y (fixnumize val)))
- (integer
- (move-immediate y (fixnumize val)))
- (symbol
- (load-symbol y val))
- (character
- (inst mov y (logior (ash (char-code val) n-widetag-bits)
- character-widetag)))))
- (move y x)))
+ (let ((val (tn-value x)))
+ (etypecase val
+ ((integer 0 0)
+ (inst xor y y))
+ ((or (signed-byte 29) (unsigned-byte 29))
+ (inst mov y (fixnumize val)))
+ (integer
+ (move-immediate y (fixnumize val)))
+ (symbol
+ (load-symbol y val))
+ (character
+ (inst mov y (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)))))
+ (move y x)))
((control-stack)
(if (sc-is x immediate)
- (let ((val (tn-value x)))
- (if (= (tn-offset fp) esp-offset)
- ;; C-call
- (etypecase val
- (integer
- (storew (fixnumize val) fp (tn-offset y)))
- (symbol
- (storew (+ nil-value (static-symbol-offset val))
- fp (tn-offset y)))
- (character
- (storew (logior (ash (char-code val) n-widetag-bits)
- character-widetag)
- fp (tn-offset y))))
- ;; Lisp stack
- (etypecase val
- (integer
- (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
- (symbol
- (storew (+ nil-value (static-symbol-offset val))
- fp (- (1+ (tn-offset y)))))
- (character
- (storew (logior (ash (char-code val) n-widetag-bits)
- character-widetag)
- fp (- (1+ (tn-offset y))))))))
- (if (= (tn-offset fp) esp-offset)
- ;; C-call
- (storew x fp (tn-offset y))
- ;; Lisp stack
- (storew x fp (- (1+ (tn-offset y))))))))))
+ (let ((val (tn-value x)))
+ (if (= (tn-offset fp) esp-offset)
+ ;; C-call
+ (etypecase val
+ (integer
+ (storew (fixnumize val) fp (tn-offset y)))
+ (symbol
+ (storew (+ nil-value (static-symbol-offset val))
+ fp (tn-offset y)))
+ (character
+ (storew (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)
+ fp (tn-offset y))))
+ ;; Lisp stack
+ (etypecase val
+ (integer
+ (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
+ (symbol
+ (storew (+ nil-value (static-symbol-offset val))
+ fp (- (1+ (tn-offset y)))))
+ (character
+ (storew (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)
+ fp (- (1+ (tn-offset y))))))))
+ (if (= (tn-offset fp) esp-offset)
+ ;; C-call
+ (storew x fp (tn-offset y))
+ ;; Lisp stack
+ (storew x fp (- (1+ (tn-offset y))))))))))
(define-move-vop move-arg :move-arg
(any-reg descriptor-reg)
;;; possible bignum arg SCs.
(define-vop (move-to-word/fixnum)
(:args (x :scs (any-reg descriptor-reg) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (signed-reg unsigned-reg)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:arg-types tagged-num)
(:note "fixnum untagging")
(:generator 1
(:results (y :scs (signed-reg unsigned-reg)))
(:note "integer to untagged word coercion")
(:temporary (:sc unsigned-reg :offset eax-offset
- :from (:argument 0) :to (:result 0) :target y) eax)
+ :from (:argument 0) :to (:result 0) :target y) eax)
(:generator 4
(move eax x)
- (inst test al-tn 7) ; a symbolic constant for this
- (inst jmp :z FIXNUM) ; would be nice
+ (inst test al-tn 7) ; a symbolic constant for this
+ (inst jmp :z FIXNUM) ; would be nice
(loadw y eax bignum-digits-offset other-pointer-lowtag)
(inst jmp DONE)
FIXNUM
;;; restriction because of the control-stack ambiguity noted above.
(define-vop (move-from-word/fixnum)
(:args (x :scs (signed-reg unsigned-reg) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (any-reg descriptor-reg)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:result-types tagged-num)
(:note "fixnum tagging")
(:generator 1
(cond ((and (sc-is x signed-reg unsigned-reg)
- (not (location= x y)))
- ;; Uses 7 bytes, but faster on the Pentium
- (inst lea y (make-ea :qword :index x :scale 8)))
- (t
- ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
- (move y x)
- (inst shl y (1- n-lowtag-bits))))))
+ (not (location= x y)))
+ ;; Uses 7 bytes, but faster on the Pentium
+ (inst lea y (make-ea :qword :index x :scale 8)))
+ (t
+ ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
+ (move y x)
+ (inst shl y (1- n-lowtag-bits))))))
(define-move-vop move-from-word/fixnum :move
(signed-reg unsigned-reg) (any-reg descriptor-reg))
(:generator 20
(aver (not (location= x y)))
(let ((bignum (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst mov y x)
(inst shl y 1)
(inst jmp :o bignum)
(emit-label done)
(assemble (*elsewhere*)
- (emit-label bignum)
- (with-fixed-allocation
- (y bignum-widetag (+ bignum-digits-offset 1) node)
- (storew x y bignum-digits-offset other-pointer-lowtag))
- (inst jmp done)))))
+ (emit-label bignum)
+ (with-fixed-allocation
+ (y bignum-widetag (+ bignum-digits-offset 1) node)
+ (storew x y bignum-digits-offset other-pointer-lowtag))
+ (inst jmp done)))))
(define-move-vop move-from-signed :move
(signed-reg) (descriptor-reg))
(aver (not (location= x alloc)))
(aver (not (location= y alloc)))
(let ((bignum (gen-label))
- (done (gen-label))
- (one-word-bignum (gen-label))
- (L1 (gen-label)))
- (inst bsr y x) ;find msb
+ (done (gen-label))
+ (one-word-bignum (gen-label))
+ (L1 (gen-label)))
+ (inst bsr y x) ;find msb
(inst cmov :z y x)
(inst cmp y 60)
(inst jmp :ae bignum)
(inst lea y (make-ea :qword :index x :scale 8))
(emit-label done)
(assemble (*elsewhere*)
- (emit-label bignum)
- ;; Note: As on the mips port, space for a two word bignum is
- ;; always allocated and the header size is set to either one
- ;; or two words as appropriate.
- (inst cmp y 63)
- (inst jmp :l one-word-bignum)
- ;; two word bignum
- (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
- n-widetag-bits)
- bignum-widetag))
- (inst jmp L1)
- (emit-label one-word-bignum)
- (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
- n-widetag-bits)
- bignum-widetag))
- (emit-label L1)
- (pseudo-atomic
- (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
- (storew y alloc)
- (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
- (storew x y bignum-digits-offset other-pointer-lowtag))
- (inst jmp done)))))
+ (emit-label bignum)
+ ;; Note: As on the mips port, space for a two word bignum is
+ ;; always allocated and the header size is set to either one
+ ;; or two words as appropriate.
+ (inst cmp y 63)
+ (inst jmp :l one-word-bignum)
+ ;; two word bignum
+ (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
+ n-widetag-bits)
+ bignum-widetag))
+ (inst jmp L1)
+ (emit-label one-word-bignum)
+ (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
+ n-widetag-bits)
+ bignum-widetag))
+ (emit-label L1)
+ (pseudo-atomic
+ (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
+ (storew y alloc)
+ (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
+ (storew x y bignum-digits-offset other-pointer-lowtag))
+ (inst jmp done)))))
(define-move-vop move-from-unsigned :move
(unsigned-reg) (descriptor-reg))
;;; Move untagged numbers.
(define-vop (word-move)
(:args (x :scs (signed-reg unsigned-reg) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (signed-reg unsigned-reg)
- :load-if
- (not (or (location= x y)
- (and (sc-is x signed-reg unsigned-reg)
- (sc-is y signed-stack unsigned-stack))))))
+ :load-if
+ (not (or (location= x y)
+ (and (sc-is x signed-reg unsigned-reg)
+ (sc-is y signed-stack unsigned-stack))))))
(:effects)
(:affected)
(:note "word integer move")
;;; Move untagged number arguments/return-values.
(define-vop (move-word-arg)
(:args (x :scs (signed-reg unsigned-reg) :target y)
- (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
+ (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "word integer argument move")
(:generator 0
(move y x))
((signed-stack unsigned-stack)
(if (= (tn-offset fp) esp-offset)
- (storew x fp (tn-offset y)) ; c-call
- (storew x fp (- (1+ (tn-offset y)))))))))
+ (storew x fp (tn-offset y)) ; c-call
+ (storew x fp (- (1+ (tn-offset y)))))))))
(define-move-vop move-word-arg :move-arg
(descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
(defun catch-block-ea (tn)
(aver (sc-is tn catch-block))
(make-ea :qword :base rbp-tn
- :disp (- (* (+ (tn-offset tn) catch-block-size) n-word-bytes))))
+ :disp (- (* (+ (tn-offset tn) catch-block-size) n-word-bytes))))
\f
;;;; Save and restore dynamic environment.
(define-vop (save-dynamic-state)
(:results (catch :scs (descriptor-reg))
- (alien-stack :scs (descriptor-reg)))
+ (alien-stack :scs (descriptor-reg)))
(:generator 13
(load-tl-symbol-value catch *current-catch-block*)
(load-tl-symbol-value alien-stack *alien-stack*)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
- (alien-stack :scs (descriptor-reg)))
+ (alien-stack :scs (descriptor-reg)))
#!+sb-thread (:temporary (:sc unsigned-reg) temp)
(:generator 10
(store-tl-symbol-value catch *current-catch-block* temp)
;;; tag, and link the block into the CURRENT-CATCH list
(define-vop (make-catch-block)
(:args (tn)
- (tag :scs (any-reg descriptor-reg) :to (:result 1)))
+ (tag :scs (any-reg descriptor-reg) :to (:result 1)))
(:info entry-label)
(:results (block :scs (any-reg)))
(:temporary (:sc descriptor-reg) temp)
;; Note: we can't list an sc-restriction, 'cause any load vops would
;; be inserted before the return-pc label.
(:args (sp)
- (start)
- (count))
+ (start)
+ (count))
(:results (values :more t))
(:temporary (:sc descriptor-reg) move-temp)
(:info label nvals)
(emit-label label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
- ((= nvals 1)
- (let ((no-values (gen-label)))
- (inst mov (tn-ref-tn values) nil-value)
- (inst jecxz no-values)
- (loadw (tn-ref-tn values) start -1)
- (emit-label no-values)))
- (t
- (collect ((defaults))
- (do ((i 0 (1+ i))
- (tn-ref values (tn-ref-across tn-ref)))
- ((null tn-ref))
- (let ((default-lab (gen-label))
- (tn (tn-ref-tn tn-ref)))
- (defaults (cons default-lab tn))
-
- (inst cmp count (fixnumize i))
- (inst jmp :le default-lab)
- (sc-case tn
- ((descriptor-reg any-reg)
- (loadw tn start (- (1+ i))))
- ((control-stack)
- (loadw move-temp start (- (1+ i)))
- (inst mov tn move-temp)))))
- (let ((defaulting-done (gen-label)))
- (emit-label defaulting-done)
- (assemble (*elsewhere*)
- (dolist (def (defaults))
- (emit-label (car def))
- (inst mov (cdr def) nil-value))
- (inst jmp defaulting-done))))))
+ ((= nvals 1)
+ (let ((no-values (gen-label)))
+ (inst mov (tn-ref-tn values) nil-value)
+ (inst jecxz no-values)
+ (loadw (tn-ref-tn values) start -1)
+ (emit-label no-values)))
+ (t
+ (collect ((defaults))
+ (do ((i 0 (1+ i))
+ (tn-ref values (tn-ref-across tn-ref)))
+ ((null tn-ref))
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn tn-ref)))
+ (defaults (cons default-lab tn))
+
+ (inst cmp count (fixnumize i))
+ (inst jmp :le default-lab)
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (loadw tn start (- (1+ i))))
+ ((control-stack)
+ (loadw move-temp start (- (1+ i)))
+ (inst mov tn move-temp)))))
+ (let ((defaulting-done (gen-label)))
+ (emit-label defaulting-done)
+ (assemble (*elsewhere*)
+ (dolist (def (defaults))
+ (emit-label (car def))
+ (inst mov (cdr def) nil-value))
+ (inst jmp defaulting-done))))))
(inst mov rsp-tn sp)))
(define-vop (nlx-entry-multiple)
(:args (top)
- (source)
- (count :target rcx))
+ (source)
+ (count :target rcx))
;; Again, no SC restrictions for the args, 'cause the loading would
;; happen before the entry label.
(:info label)
(:temporary (:sc unsigned-reg :offset rsi-offset) rsi)
(:temporary (:sc unsigned-reg :offset rdi-offset) rdi)
(:results (result :scs (any-reg) :from (:argument 0))
- (num :scs (any-reg control-stack)))
+ (num :scs (any-reg control-stack)))
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(move result rdi)
(inst sub rdi n-word-bytes)
- (move rcx count) ; fixnum words == bytes
+ (move rcx count) ; fixnum words == bytes
(move num rcx)
- (inst shr rcx word-shift) ; word count for <rep movs>
+ (inst shr rcx word-shift) ; word count for <rep movs>
;; If we got zero, we be done.
(inst jecxz DONE)
;; Copy them down.
;;; These values were taken from the alpha code. The values for
;;; bias and exponent min/max are not the same as shown in the 486 book.
;;; They may be correct for how Python uses them.
-(def!constant single-float-bias 126) ; Intel says 127.
+(def!constant single-float-bias 126) ; Intel says 127.
(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp)
(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp)
;;; comment from CMU CL:
(+ (byte-size double-float-significand-byte) 32 1))
;;; from AMD64 Architecture manual
-(def!constant float-invalid-trap-bit (ash 1 0))
+(def!constant float-invalid-trap-bit (ash 1 0))
(def!constant float-denormal-trap-bit (ash 1 1))
(def!constant float-divide-by-zero-trap-bit (ash 1 2))
(def!constant float-overflow-trap-bit (ash 1 3))
(def!constant float-underflow-trap-bit (ash 1 4))
-(def!constant float-inexact-trap-bit (ash 1 5))
+(def!constant float-inexact-trap-bit (ash 1 5))
(def!constant float-round-to-nearest 0)
(def!constant float-round-to-negative 1)
fdefinition-object
;; free pointers
- ;;
+ ;;
;; Note that these are FIXNUM word counts, not (as one might
;; expect) byte counts or SAPs. The reason seems to be that by
- ;; representing them this way, we can avoid consing bignums.
+ ;; representing them this way, we can avoid consing bignums.
;; -- WHN 2000-10-02
*read-only-space-free-pointer*
*static-space-free-pointer*
*free-interrupt-context-index*
*free-tls-index*
-
+
*allocation-pointer*
*binding-stack-pointer*
*binding-stack-start*
;;; not immediate data.
(define-vop (if-eq)
(:args (x :scs (any-reg descriptor-reg control-stack constant)
- :load-if (not (and (sc-is x immediate)
- (sc-is y any-reg descriptor-reg
- control-stack constant))))
- (y :scs (any-reg descriptor-reg immediate)
- :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
- (sc-is y control-stack constant)))))
+ :load-if (not (and (sc-is x immediate)
+ (sc-is y any-reg descriptor-reg
+ control-stack constant))))
+ (y :scs (any-reg descriptor-reg immediate)
+ :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
+ (sc-is y control-stack constant)))))
(:temporary (:sc descriptor-reg) temp)
(:conditional)
(:info target not-p)
(cond
((sc-is y immediate)
(let ((val (tn-value y)))
- (etypecase val
- (integer
- (if (and (zerop val) (sc-is x any-reg descriptor-reg))
- (inst test x x) ; smaller
- (let ((fixnumized (fixnumize val)))
- (if (typep fixnumized
- '(or (signed-byte 32) (unsigned-byte 31)))
- (inst cmp x fixnumized)
- (progn
- (inst mov temp fixnumized)
- (inst cmp x temp))))))
- (symbol
- (inst cmp x (+ nil-value (static-symbol-offset val))))
- (character
- (inst cmp x (logior (ash (char-code val) n-widetag-bits)
- character-widetag))))))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is x any-reg descriptor-reg))
+ (inst test x x) ; smaller
+ (let ((fixnumized (fixnumize val)))
+ (if (typep fixnumized
+ '(or (signed-byte 32) (unsigned-byte 31)))
+ (inst cmp x fixnumized)
+ (progn
+ (inst mov temp fixnumized)
+ (inst cmp x temp))))))
+ (symbol
+ (inst cmp x (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst cmp x (logior (ash (char-code val) n-widetag-bits)
+ character-widetag))))))
((sc-is x immediate) ; and y not immediate
;; Swap the order to fit the compare instruction.
(let ((val (tn-value x)))
- (etypecase val
- (integer
- (if (and (zerop val) (sc-is y any-reg descriptor-reg))
- (inst test y y) ; smaller
- (let ((fixnumized (fixnumize val)))
- (if (typep fixnumized
- '(or (signed-byte 32) (unsigned-byte 31)))
- (inst cmp y fixnumized)
- (progn
- (inst mov temp fixnumized)
- (inst cmp y temp))))))
- (symbol
- (inst cmp y (+ nil-value (static-symbol-offset val))))
- (character
- (inst cmp y (logior (ash (char-code val) n-widetag-bits)
- character-widetag))))))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+ (inst test y y) ; smaller
+ (let ((fixnumized (fixnumize val)))
+ (if (typep fixnumized
+ '(or (signed-byte 32) (unsigned-byte 31)))
+ (inst cmp y fixnumized)
+ (progn
+ (inst mov temp fixnumized)
+ (inst cmp y temp))))))
+ (symbol
+ (inst cmp y (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst cmp y (logior (ash (char-code val) n-widetag-bits)
+ character-widetag))))))
(t
(inst cmp x y)))
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
-;;;;
+;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;;; Move untagged sap values.
(define-vop (sap-move)
(:args (x :target y
- :scs (sap-reg)
- :load-if (not (location= x y))))
+ :scs (sap-reg)
+ :load-if (not (location= x y))))
(:results (y :scs (sap-reg)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:note "SAP move")
(:effects)
(:affected)
;;; Move untagged sap arguments/return-values.
(define-vop (move-sap-arg)
(:args (x :target y
- :scs (sap-reg))
- (fp :scs (any-reg)
- :load-if (not (sc-is y sap-reg))))
+ :scs (sap-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "SAP argument move")
(:generator 0
(move y x))
(sap-stack
(if (= (tn-offset fp) esp-offset)
- (storew x fp (tn-offset y)) ; c-call
- (storew x fp (- (1+ (tn-offset y)))))))))
+ (storew x fp (tn-offset y)) ; c-call
+ (storew x fp (- (1+ (tn-offset y)))))))))
(define-move-vop move-sap-arg :move-arg
(descriptor-reg sap-reg) (sap-reg))
(define-vop (pointer+)
(:translate sap+)
(:args (ptr :scs (sap-reg) :target res
- :load-if (not (location= ptr res)))
- (offset :scs (signed-reg immediate)))
+ :load-if (not (location= ptr res)))
+ (offset :scs (signed-reg immediate)))
(:arg-types system-area-pointer signed-num)
(:results (res :scs (sap-reg) :from (:argument 0)
- :load-if (not (location= ptr res))))
+ :load-if (not (location= ptr res))))
(:result-types system-area-pointer)
(:temporary (:sc signed-reg) temp)
(:policy :fast-safe)
(:generator 1
(cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg)
- (not (location= ptr res)))
- (sc-case offset
- (signed-reg
- (inst lea res (make-ea :qword :base ptr :index offset :scale 1)))
- (immediate
- (let ((value (tn-value offset)))
- (cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
- (inst lea res (make-ea :qword :base ptr :disp value)))
- (t
- (inst mov temp value)
- (inst lea res (make-ea :qword :base ptr
- :index temp
- :scale 1))))))))
- (t
- (move res ptr)
- (sc-case offset
- (signed-reg
- (inst add res offset))
- (immediate
- (let ((value (tn-value offset)))
- (cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
- (inst add res (tn-value offset)))
- (t
- (inst mov temp value)
- (inst add res temp))))))))))
+ (not (location= ptr res)))
+ (sc-case offset
+ (signed-reg
+ (inst lea res (make-ea :qword :base ptr :index offset :scale 1)))
+ (immediate
+ (let ((value (tn-value offset)))
+ (cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
+ (inst lea res (make-ea :qword :base ptr :disp value)))
+ (t
+ (inst mov temp value)
+ (inst lea res (make-ea :qword :base ptr
+ :index temp
+ :scale 1))))))))
+ (t
+ (move res ptr)
+ (sc-case offset
+ (signed-reg
+ (inst add res offset))
+ (immediate
+ (let ((value (tn-value offset)))
+ (cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
+ (inst add res (tn-value offset)))
+ (t
+ (inst mov temp value)
+ (inst add res temp))))))))))
(define-vop (pointer-)
(:translate sap-)
(:args (ptr1 :scs (sap-reg) :target res)
- (ptr2 :scs (sap-reg)))
+ (ptr2 :scs (sap-reg)))
(:arg-types system-area-pointer system-area-pointer)
(:policy :fast-safe)
(:results (res :scs (signed-reg) :from (:argument 0)))
;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
(macrolet ((def-system-ref-and-set (ref-name
- set-name
- sc
- type
- size
- &optional signed)
- (let ((ref-name-c (symbolicate ref-name "-C"))
- (set-name-c (symbolicate set-name "-C"))
- (temp-sc (symbolicate size "-REG")))
- `(progn
- (define-vop (,ref-name)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg))
- (offset :scs (signed-reg)))
- (:arg-types system-area-pointer signed-num)
- ,@(unless (eq size :qword)
- `((:temporary (:sc ,temp-sc
- :from (:eval 0)
- :to (:eval 1))
- temp)))
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- (inst mov ,(if (eq size :qword) 'result 'temp)
- (make-ea ,size :base sap :index offset))
- ,@(unless (eq size :qword)
- `((inst ,(if signed 'movsx 'movzx)
- result temp)))))
- (define-vop (,ref-name-c)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg)))
- (:arg-types system-area-pointer
- (:constant (signed-byte 64)))
- (:info offset)
- ,@(unless (eq size :qword)
- `((:temporary (:sc ,temp-sc
- :from (:eval 0)
- :to (:eval 1))
- temp)))
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- (inst mov ,(if (eq size :qword) 'result 'temp)
- (make-ea ,size :base sap :disp offset))
- ,@(unless (eq size :qword)
- `((inst ,(if signed 'movsx 'movzx)
- result temp)))))
- (define-vop (,set-name)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg) :to (:eval 0))
- (offset :scs (signed-reg) :to (:eval 0))
- (value :scs (,sc)
- :target ,(if (eq size :qword)
- 'result
- 'temp)))
- (:arg-types system-area-pointer signed-num ,type)
- ,@(unless (eq size :qword)
- `((:temporary (:sc ,temp-sc :offset rax-offset
- :from (:argument 2) :to (:result 0)
- :target result)
- temp)))
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- ,@(unless (eq size :qword)
- `((move rax-tn value)))
- (inst mov (make-ea ,size
- :base sap
- :index offset)
- ,(if (eq size :qword) 'value 'temp))
- (move result
- ,(if (eq size :qword) 'value 'rax-tn))))
- (define-vop (,set-name-c)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg) :to (:eval 0))
- (value :scs (,sc)
- :target ,(if (eq size :qword)
- 'result
- 'temp)))
- (:arg-types system-area-pointer
- (:constant (signed-byte 64)) ,type)
- (:info offset)
- ,@(unless (eq size :qword)
- `((:temporary (:sc ,temp-sc :offset rax-offset
- :from (:argument 2) :to (:result 0)
- :target result)
- temp)))
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- ,@(unless (eq size :qword)
- `((move rax-tn value)))
- (inst mov
- (make-ea ,size :base sap :disp offset)
- ,(if (eq size :qword) 'value 'temp))
- (move result ,(if (eq size :qword)
- 'value
- 'rax-tn))))))))
+ set-name
+ sc
+ type
+ size
+ &optional signed)
+ (let ((ref-name-c (symbolicate ref-name "-C"))
+ (set-name-c (symbolicate set-name "-C"))
+ (temp-sc (symbolicate size "-REG")))
+ `(progn
+ (define-vop (,ref-name)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ ,@(unless (eq size :qword)
+ `((:temporary (:sc ,temp-sc
+ :from (:eval 0)
+ :to (:eval 1))
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ (inst mov ,(if (eq size :qword) 'result 'temp)
+ (make-ea ,size :base sap :index offset))
+ ,@(unless (eq size :qword)
+ `((inst ,(if signed 'movsx 'movzx)
+ result temp)))))
+ (define-vop (,ref-name-c)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg)))
+ (:arg-types system-area-pointer
+ (:constant (signed-byte 64)))
+ (:info offset)
+ ,@(unless (eq size :qword)
+ `((:temporary (:sc ,temp-sc
+ :from (:eval 0)
+ :to (:eval 1))
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ (inst mov ,(if (eq size :qword) 'result 'temp)
+ (make-ea ,size :base sap :disp offset))
+ ,@(unless (eq size :qword)
+ `((inst ,(if signed 'movsx 'movzx)
+ result temp)))))
+ (define-vop (,set-name)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (,sc)
+ :target ,(if (eq size :qword)
+ 'result
+ 'temp)))
+ (:arg-types system-area-pointer signed-num ,type)
+ ,@(unless (eq size :qword)
+ `((:temporary (:sc ,temp-sc :offset rax-offset
+ :from (:argument 2) :to (:result 0)
+ :target result)
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(unless (eq size :qword)
+ `((move rax-tn value)))
+ (inst mov (make-ea ,size
+ :base sap
+ :index offset)
+ ,(if (eq size :qword) 'value 'temp))
+ (move result
+ ,(if (eq size :qword) 'value 'rax-tn))))
+ (define-vop (,set-name-c)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (value :scs (,sc)
+ :target ,(if (eq size :qword)
+ 'result
+ 'temp)))
+ (:arg-types system-area-pointer
+ (:constant (signed-byte 64)) ,type)
+ (:info offset)
+ ,@(unless (eq size :qword)
+ `((:temporary (:sc ,temp-sc :offset rax-offset
+ :from (:argument 2) :to (:result 0)
+ :target result)
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ ,@(unless (eq size :qword)
+ `((move rax-tn value)))
+ (inst mov
+ (make-ea ,size :base sap :disp offset)
+ ,(if (eq size :qword) 'value 'temp))
+ (move result ,(if (eq size :qword)
+ 'value
+ 'rax-tn))))))))
(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
unsigned-reg positive-fixnum :byte nil)
(:translate sap-ref-double)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (offset :scs (signed-reg)))
+ (offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:translate %set-sap-ref-double)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to (:eval 0))
- (offset :scs (signed-reg) :to (:eval 0))
- (value :scs (double-reg)))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (double-reg)))
(:arg-types system-area-pointer signed-num double-float)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:translate %set-sap-ref-double)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to (:eval 0))
- (value :scs (double-reg)))
+ (value :scs (double-reg)))
(:arg-types system-area-pointer (:constant (signed-byte 64)) double-float)
(:info offset)
(:results (result :scs (double-reg)))
(:translate sap-ref-single)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (offset :scs (signed-reg)))
+ (offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:translate %set-sap-ref-single)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to (:eval 0))
- (offset :scs (signed-reg) :to (:eval 0))
- (value :scs (single-reg)))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (single-reg)))
(:arg-types system-area-pointer signed-num single-float)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:translate %set-sap-ref-single)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to (:eval 0))
- (value :scs (single-reg)))
+ (value :scs (single-reg)))
(:arg-types system-area-pointer (:constant (signed-byte 32)) single-float)
(:info offset)
(:results (result :scs (single-reg)))
(:generator 2
(move sap vector)
(inst add
- sap
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
+ sap
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
(define-vop (print)
(:args (object :scs (descriptor-reg any-reg)))
(:temporary (:sc unsigned-reg
- :offset rax-offset
- :target result
- :from :eval
- :to (:result 0))
- rax)
+ :offset rax-offset
+ :target result
+ :from :eval
+ :to (:result 0))
+ rax)
(:temporary (:sc unsigned-reg) call-target)
(:results (result :scs (descriptor-reg)))
(:save-p t)
(inst push object)
(inst lea rax (make-fixup "debug_print" :foreign))
(inst lea call-target
- (make-ea :qword
- :disp (make-fixup "call_into_c" :foreign)))
+ (make-ea :qword
+ :disp (make-fixup "call_into_c" :foreign)))
(inst call call-target)
(inst add rsp-tn n-word-bytes)
(move result rax)))
(:vop-var vop)
(:node-var node)
(:temporary (:sc unsigned-reg :offset ebx-offset
- :from (:eval 0) :to (:eval 2)) ebx)
+ :from (:eval 0) :to (:eval 2)) ebx)
(:temporary (:sc unsigned-reg :offset ecx-offset
- :from (:eval 0) :to (:eval 2)) ecx))
+ :from (:eval 0) :to (:eval 2)) ecx))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun static-fun-template-name (num-args num-results)
(intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
- num-args num-results)))
+ num-args num-results)))
(defun moves (dst src)
(collect ((moves))
(do ((dst dst (cdr dst))
- (src src (cdr src)))
- ((or (null dst) (null src)))
+ (src src (cdr src)))
+ ((or (null dst) (null src)))
(moves `(move ,(car dst) ,(car src))))
(moves)))
(defun static-fun-template-vop (num-args num-results)
(unless (and (<= num-args register-arg-count)
- (<= num-results register-arg-count))
+ (<= num-results register-arg-count))
(error "either too many args (~W) or too many results (~W); max = ~W"
- num-args num-results register-arg-count))
+ num-args num-results register-arg-count))
(let ((num-temps (max num-args num-results)))
(collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
(dotimes (i num-results)
- (let ((result-name (intern (format nil "RESULT-~D" i))))
- (result-names result-name)
- (results `(,result-name :scs (any-reg descriptor-reg)))))
+ (let ((result-name (intern (format nil "RESULT-~D" i))))
+ (result-names result-name)
+ (results `(,result-name :scs (any-reg descriptor-reg)))))
(dotimes (i num-temps)
- (let ((temp-name (intern (format nil "TEMP-~D" i))))
- (temp-names temp-name)
- (temps `(:temporary (:sc descriptor-reg
- :offset ,(nth i *register-arg-offsets*)
- :from ,(if (< i num-args)
- `(:argument ,i)
- '(:eval 1))
- :to ,(if (< i num-results)
- `(:result ,i)
- '(:eval 1))
- ,@(when (< i num-results)
- `(:target ,(nth i (result-names)))))
- ,temp-name))))
+ (let ((temp-name (intern (format nil "TEMP-~D" i))))
+ (temp-names temp-name)
+ (temps `(:temporary (:sc descriptor-reg
+ :offset ,(nth i *register-arg-offsets*)
+ :from ,(if (< i num-args)
+ `(:argument ,i)
+ '(:eval 1))
+ :to ,(if (< i num-results)
+ `(:result ,i)
+ '(:eval 1))
+ ,@(when (< i num-results)
+ `(:target ,(nth i (result-names)))))
+ ,temp-name))))
(dotimes (i num-args)
- (let ((arg-name (intern (format nil "ARG-~D" i))))
- (arg-names arg-name)
- (args `(,arg-name
- :scs (any-reg descriptor-reg)
- :target ,(nth i (temp-names))))))
+ (let ((arg-name (intern (format nil "ARG-~D" i))))
+ (arg-names arg-name)
+ (args `(,arg-name
+ :scs (any-reg descriptor-reg)
+ :target ,(nth i (temp-names))))))
`(define-vop (,(static-fun-template-name num-args num-results)
- static-fun-template)
- (:args ,@(args))
- ,@(temps)
- (:temporary (:sc unsigned-reg) call-target)
- (:results ,@(results))
- (:generator ,(+ 50 num-args num-results)
- ,@(moves (temp-names) (arg-names))
+ static-fun-template)
+ (:args ,@(args))
+ ,@(temps)
+ (:temporary (:sc unsigned-reg) call-target)
+ (:results ,@(results))
+ (:generator ,(+ 50 num-args num-results)
+ ,@(moves (temp-names) (arg-names))
- ;; If speed not more important than size, duplicate the
- ;; effect of the ENTER with discrete instructions. Takes
- ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes.
- (cond ((policy node (>= speed space))
- (inst mov ebx rsp-tn)
- ;; Save the old-fp
- (inst push rbp-tn)
- ;; Ensure that at least three slots are available; one
- ;; above, two more needed.
- (inst sub rsp-tn (fixnumize 2))
- (inst mov rbp-tn ebx))
- (t
- (inst enter (fixnumize 2))
- ;; The enter instruction pushes EBP and then copies
- ;; ESP into EBP. We want the new EBP to be the
- ;; original ESP, so we fix it up afterwards.
- (inst add rbp-tn (fixnumize 1))))
+ ;; If speed not more important than size, duplicate the
+ ;; effect of the ENTER with discrete instructions. Takes
+ ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes.
+ (cond ((policy node (>= speed space))
+ (inst mov ebx rsp-tn)
+ ;; Save the old-fp
+ (inst push rbp-tn)
+ ;; Ensure that at least three slots are available; one
+ ;; above, two more needed.
+ (inst sub rsp-tn (fixnumize 2))
+ (inst mov rbp-tn ebx))
+ (t
+ (inst enter (fixnumize 2))
+ ;; The enter instruction pushes EBP and then copies
+ ;; ESP into EBP. We want the new EBP to be the
+ ;; original ESP, so we fix it up afterwards.
+ (inst add rbp-tn (fixnumize 1))))
- ,(if (zerop num-args)
- '(inst xor ecx ecx)
- `(inst mov ecx (fixnumize ,num-args)))
+ ,(if (zerop num-args)
+ '(inst xor ecx ecx)
+ `(inst mov ecx (fixnumize ,num-args)))
- (note-this-location vop :call-site)
- ;; Old CMU CL comment:
- ;; STATIC-FUN-OFFSET gives the offset from the start of
- ;; the NIL object to the static function FDEFN and has the
- ;; low tag of 1 added. When the NIL symbol value with its
- ;; low tag of 3 is added the resulting value points to the
- ;; raw address slot of the fdefn (at +4).
- ;; FIXME: Since the fork from CMU CL, we've swapped
- ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the
- ;; text above is no longer right. Mysteriously, things still
- ;; work. It would be good to explain why. (Is this code no
- ;; longer executed? Does it not depend on the
- ;; 1+3=4=fdefn_raw_address_offset relationship above?
- ;; Is something else going on?)
+ (note-this-location vop :call-site)
+ ;; Old CMU CL comment:
+ ;; STATIC-FUN-OFFSET gives the offset from the start of
+ ;; the NIL object to the static function FDEFN and has the
+ ;; low tag of 1 added. When the NIL symbol value with its
+ ;; low tag of 3 is added the resulting value points to the
+ ;; raw address slot of the fdefn (at +4).
+ ;; FIXME: Since the fork from CMU CL, we've swapped
+ ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the
+ ;; text above is no longer right. Mysteriously, things still
+ ;; work. It would be good to explain why. (Is this code no
+ ;; longer executed? Does it not depend on the
+ ;; 1+3=4=fdefn_raw_address_offset relationship above?
+ ;; Is something else going on?)
- ;; Need to load the target address into a register, since
- ;; immediate call arguments are just a 32-bit displacement,
- ;; which obviously can't work with >4G spaces.
- (inst mov call-target
- (make-ea :qword
- :disp (+ nil-value (static-fun-offset function))))
- (inst call call-target)
- ,(collect ((bindings) (links))
- (do ((temp (temp-names) (cdr temp))
- (name 'values (gensym))
- (prev nil name)
- (i 0 (1+ i)))
- ((= i num-results))
- (bindings `(,name
- (make-tn-ref ,(car temp) nil)))
- (when prev
- (links `(setf (tn-ref-across ,prev) ,name))))
- `(let ,(bindings)
- ,@(links)
- (default-unknown-values
- vop
- ,(if (zerop num-results) nil 'values)
- ,num-results)))
- ,@(moves (result-names) (temp-names)))))))
+ ;; Need to load the target address into a register, since
+ ;; immediate call arguments are just a 32-bit displacement,
+ ;; which obviously can't work with >4G spaces.
+ (inst mov call-target
+ (make-ea :qword
+ :disp (+ nil-value (static-fun-offset function))))
+ (inst call call-target)
+ ,(collect ((bindings) (links))
+ (do ((temp (temp-names) (cdr temp))
+ (name 'values (gensym))
+ (prev nil name)
+ (i 0 (1+ i)))
+ ((= i num-results))
+ (bindings `(,name
+ (make-tn-ref ,(car temp) nil)))
+ (when prev
+ (links `(setf (tn-ref-across ,prev) ,name))))
+ `(let ,(bindings)
+ ,@(links)
+ (default-unknown-values
+ vop
+ ,(if (zerop num-results) nil 'values)
+ ,num-results)))
+ ,@(moves (result-names) (temp-names)))))))
) ; EVAL-WHEN
(macrolet ((frob (num-args num-res)
- (static-fun-template-vop (eval num-args) (eval num-res))))
+ (static-fun-template-vop (eval num-args) (eval num-res))))
(frob 0 1)
(frob 1 1)
(frob 2 1)
(frob 3 1))
(defmacro define-static-fun (name args &key (results '(x)) translate
- policy cost arg-types result-types)
+ policy cost arg-types result-types)
`(define-vop (,name
- ,(static-fun-template-name (length args)
- (length results)))
+ ,(static-fun-template-name (length args)
+ (length results)))
(:variant ',name)
(:note ,(format nil "static-fun ~@(~S~)" name))
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
,@(when policy
- `((:policy ,policy)))
+ `((:policy ,policy)))
,@(when cost
- `((:generator-cost ,cost)))
+ `((:generator-cost ,cost)))
,@(when arg-types
- `((:arg-types ,@arg-types)))
+ `((:arg-types ,@arg-types)))
,@(when result-types
- `((:result-types ,@result-types)))))
+ `((:result-types ,@result-types)))))
(:translate lowtag-of)
(:policy :fast-safe)
(:args (object :scs (any-reg descriptor-reg control-stack)
- :target result))
+ :target result))
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 1
(:translate (setf fun-subtype))
(:policy :fast-safe)
(:args (type :scs (unsigned-reg) :target eax)
- (function :scs (descriptor-reg)))
+ (function :scs (descriptor-reg)))
(:arg-types positive-fixnum *)
(:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 0)
- :to (:result 0) :target result)
- eax)
+ :to (:result 0) :target result)
+ eax)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
(move eax type)
(inst mov
- (make-ea :byte :base function :disp (- fun-pointer-lowtag))
- al-tn)
+ (make-ea :byte :base function :disp (- fun-pointer-lowtag))
+ al-tn)
(move result eax)))
(define-vop (get-header-data)
(:translate set-header-data)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg) :target res :to (:result 0))
- (data :scs (any-reg) :target eax))
+ (data :scs (any-reg) :target eax))
(:arg-types * positive-fixnum)
(:results (res :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg :offset eax-offset
- :from (:argument 1) :to (:result 0)) eax)
+ :from (:argument 1) :to (:result 0)) eax)
(:generator 6
(move eax data)
(inst shl eax (- n-widetag-bits n-fixnum-tag-bits))
(define-vop (make-other-immediate-type)
(:args (val :scs (any-reg descriptor-reg) :target res)
- (type :scs (unsigned-reg immediate)))
+ (type :scs (unsigned-reg immediate)))
(:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
(:generator 2
(move res val)
(inst shl res (- n-widetag-bits n-fixnum-tag-bits))
(inst or res (sc-case type
- (unsigned-reg type)
- (immediate (tn-value type))))))
+ (unsigned-reg type)
+ (immediate (tn-value type))))))
\f
;;;; allocation
(:generator 10
(loadw sap code 0 other-pointer-lowtag)
(inst shr sap n-widetag-bits)
- (inst lea sap (make-ea :byte :base code :index sap
- :scale n-word-bytes
- :disp (- other-pointer-lowtag)))))
+ (inst lea sap (make-ea :byte :base code :index sap
+ :scale n-word-bytes
+ :disp (- other-pointer-lowtag)))))
(define-vop (compute-fun)
(:args (code :scs (descriptor-reg) :to (:result 0))
- (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
+ (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
(:arg-types * positive-fixnum)
(:results (func :scs (descriptor-reg) :from (:argument 0)))
(:generator 10
(loadw func code 0 other-pointer-lowtag)
(inst shr func n-widetag-bits)
(inst lea func
- (make-ea :byte :base offset :index func
- :scale n-word-bytes
- :disp (- fun-pointer-lowtag other-pointer-lowtag)))
+ (make-ea :byte :base offset :index func
+ :scale n-word-bytes
+ :disp (- fun-pointer-lowtag other-pointer-lowtag)))
(inst add func code)))
(define-vop (%simple-fun-self)
(:generator 3
(loadw result function simple-fun-self-slot fun-pointer-lowtag)
(inst lea result
- (make-ea :byte :base result
- :disp (- fun-pointer-lowtag
- (* simple-fun-code-offset n-word-bytes))))))
+ (make-ea :byte :base result
+ :disp (- fun-pointer-lowtag
+ (* simple-fun-code-offset n-word-bytes))))))
;;; The closure function slot is a pointer to raw code on X86 instead
;;; of a pointer to the code function object itself. This VOP is used
(:policy :fast-safe)
(:translate (setf %simple-fun-self))
(:args (new-self :scs (descriptor-reg) :target result :to :result)
- (function :scs (descriptor-reg) :to :result))
+ (function :scs (descriptor-reg) :to :result))
(:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
(:results (result :scs (descriptor-reg)))
(:generator 3
(inst lea temp
- (make-ea :byte :base new-self
- :disp (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag)))
+ (make-ea :byte :base new-self
+ :disp (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag)))
(storew temp function simple-fun-self-slot fun-pointer-lowtag)
(move result new-self)))
(inst break pending-interrupt-trap)))
#!+sb-thread
-(defknown current-thread-offset-sap ((unsigned-byte 64))
+(defknown current-thread-offset-sap ((unsigned-byte 64))
system-area-pointer (flushable))
#!+sb-thread
(:arg-types unsigned-num)
(:policy :fast-safe)
(:generator 2
- (inst mov sap
- (make-ea :qword :base thread-base-tn :disp 0 :index n :scale 8))))
+ (inst mov sap
+ (make-ea :qword :base thread-base-tn :disp 0 :index n :scale 8))))
(define-vop (halt)
(:generator 1
(:info index)
(:generator 0
(inst inc (make-ea :qword :base count-vector
- :disp (- (* (+ vector-data-offset index) n-word-bytes)
- other-pointer-lowtag)))))
+ :disp (- (* (+ vector-data-offset index) n-word-bytes)
+ other-pointer-lowtag)))))
;;; :QWORD and a corresponding size indicator is printed first.
(defun print-mem-access (value width stream dstate)
(declare (type list value)
- (type (member nil :byte :word :dword :qword) width)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type (member nil :byte :word :dword :qword) width)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(when width
(princ width stream)
(princ '| PTR | stream))
(write-char #\[ stream)
(let ((firstp t) (rip-p nil))
(macrolet ((pel ((var val) &body body)
- ;; Print an element of the address, maybe with
- ;; a leading separator.
- `(let ((,var ,val))
- (when ,var
- (unless firstp
- (write-char #\+ stream))
- ,@body
- (setq firstp nil)))))
+ ;; Print an element of the address, maybe with
+ ;; a leading separator.
+ `(let ((,var ,val))
+ (when ,var
+ (unless firstp
+ (write-char #\+ stream))
+ ,@body
+ (setq firstp nil)))))
(pel (base-reg (first value))
- (cond ((eql 'rip base-reg)
- (setf rip-p t)
- (princ base-reg stream))
- (t
- (print-addr-reg base-reg stream dstate))))
+ (cond ((eql 'rip base-reg)
+ (setf rip-p t)
+ (princ base-reg stream))
+ (t
+ (print-addr-reg base-reg stream dstate))))
(pel (index-reg (third value))
- (print-addr-reg index-reg stream dstate)
- (let ((index-scale (fourth value)))
- (when (and index-scale (not (= index-scale 1)))
- (write-char #\* stream)
- (princ index-scale stream))))
+ (print-addr-reg index-reg stream dstate)
+ (let ((index-scale (fourth value)))
+ (when (and index-scale (not (= index-scale 1)))
+ (write-char #\* stream)
+ (princ index-scale stream))))
(let ((offset (second value)))
- (when (and offset (or firstp (not (zerop offset))))
- (unless (or firstp (minusp offset))
- (write-char #\+ stream))
- (cond
- (rip-p
- (princ offset stream)
- (let ((addr (+ offset (sb!disassem:dstate-next-addr dstate))))
- (when (plusp addr)
- (or (nth-value 1
- (sb!disassem::note-code-constant-absolute
- addr dstate))
- (sb!disassem:maybe-note-assembler-routine addr
- nil
- dstate)))))
- (firstp
- (progn
- (sb!disassem:princ16 offset stream)
- (or (minusp offset)
- (nth-value 1
- (sb!disassem::note-code-constant-absolute offset dstate))
- (sb!disassem:maybe-note-assembler-routine offset
- nil
- dstate))))
+ (when (and offset (or firstp (not (zerop offset))))
+ (unless (or firstp (minusp offset))
+ (write-char #\+ stream))
+ (cond
+ (rip-p
+ (princ offset stream)
+ (let ((addr (+ offset (sb!disassem:dstate-next-addr dstate))))
+ (when (plusp addr)
+ (or (nth-value 1
+ (sb!disassem::note-code-constant-absolute
+ addr dstate))
+ (sb!disassem:maybe-note-assembler-routine addr
+ nil
+ dstate)))))
+ (firstp
+ (progn
+ (sb!disassem:princ16 offset stream)
+ (or (minusp offset)
+ (nth-value 1
+ (sb!disassem::note-code-constant-absolute offset dstate))
+ (sb!disassem:maybe-note-assembler-routine offset
+ nil
+ dstate))))
(t
(princ offset stream)))))))
(write-char #\] stream))
(defun make-byte-tn (tn)
(aver (sc-is tn any-reg descriptor-reg unsigned-reg signed-reg))
(make-random-tn :kind :normal
- :sc (sc-or-lose 'byte-reg)
- :offset (tn-offset tn)))
+ :sc (sc-or-lose 'byte-reg)
+ :offset (tn-offset tn)))
(defun generate-fixnum-test (value)
"zero flag set if VALUE is fixnum"
(let ((offset (tn-offset value)))
;; The x86 backend uses a pun from E[A-D]X -> [A-D]L for these
- ;; tests. The Athlon 64 optimization guide says that this is a
+ ;; tests. The Athlon 64 optimization guide says that this is a
;; bad idea, so it's been removed.
(cond ((sc-is value control-stack)
- (inst test (make-ea :byte :base rbp-tn
- :disp (- (* (1+ offset) n-word-bytes)))
- sb!vm::fixnum-tag-mask))
- (t
- (inst test value sb!vm::fixnum-tag-mask)))))
+ (inst test (make-ea :byte :base rbp-tn
+ :disp (- (* (1+ offset) n-word-bytes)))
+ sb!vm::fixnum-tag-mask))
+ (t
+ (inst test value sb!vm::fixnum-tag-mask)))))
(defun %test-fixnum (value target not-p)
(generate-fixnum-test value)
(%test-immediate value target not-p immediate drop-through)))
(defun %test-fixnum-immediate-and-headers (value target not-p immediate
- headers)
+ headers)
(let ((drop-through (gen-label)))
(generate-fixnum-test value)
(inst jmp :z (if not-p drop-through target))
(%test-immediate-and-headers value target not-p immediate headers
- drop-through)))
+ drop-through)))
(defun %test-immediate (value target not-p immediate
- &optional (drop-through (gen-label)))
+ &optional (drop-through (gen-label)))
;; Code a single instruction byte test if possible.
(cond ((sc-is value any-reg descriptor-reg)
- (inst cmp (make-byte-tn value) immediate))
- (t
- (move rax-tn value)
- (inst cmp al-tn immediate)))
- (inst jmp (if not-p :ne :e) target)
- (emit-label drop-through))
+ (inst cmp (make-byte-tn value) immediate))
+ (t
+ (move rax-tn value)
+ (inst cmp al-tn immediate)))
+ (inst jmp (if not-p :ne :e) target)
+ (emit-label drop-through))
(defun %test-immediate-and-headers (value target not-p immediate headers
- &optional (drop-through (gen-label)))
+ &optional (drop-through (gen-label)))
;; Code a single instruction byte test if possible.
(cond ((sc-is value any-reg descriptor-reg)
- (inst cmp (make-byte-tn value) immediate))
- (t
- (move rax-tn value)
- (inst cmp al-tn immediate)))
+ (inst cmp (make-byte-tn value) immediate))
+ (t
+ (move rax-tn value)
+ (inst cmp al-tn immediate)))
(inst jmp :e (if not-p drop-through target))
(%test-headers value target not-p nil headers drop-through))
(inst jmp (if not-p :ne :e) target))
(defun %test-headers (value target not-p function-p headers
- &optional (drop-through (gen-label)))
+ &optional (drop-through (gen-label)))
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind (equal less-or-equal when-true when-false)
- ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
- ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
- ;; it's true and when we know it's false respectively.
- (if not-p
- (values :ne :a drop-through target)
- (values :e :na target drop-through))
+ ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
+ ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
+ ;; it's true and when we know it's false respectively.
+ (if not-p
+ (values :ne :a drop-through target)
+ (values :e :na target drop-through))
(%test-lowtag value when-false t lowtag)
(inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
(do ((remaining headers (cdr remaining)))
- ((null remaining))
- (let ((header (car remaining))
- (last (null (cdr remaining))))
- (cond
- ((atom header)
- (inst cmp al-tn header)
- (if last
- (inst jmp equal target)
- (inst jmp :e when-true)))
- (t
- (let ((start (car header))
- (end (cdr header)))
- (unless (= start bignum-widetag)
- (inst cmp al-tn start)
- (inst jmp :b when-false)) ; was :l
- (inst cmp al-tn end)
- (if last
- (inst jmp less-or-equal target)
- (inst jmp :be when-true))))))) ; was :le
+ ((null remaining))
+ (let ((header (car remaining))
+ (last (null (cdr remaining))))
+ (cond
+ ((atom header)
+ (inst cmp al-tn header)
+ (if last
+ (inst jmp equal target)
+ (inst jmp :e when-true)))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ (unless (= start bignum-widetag)
+ (inst cmp al-tn start)
+ (inst jmp :b when-false)) ; was :l
+ (inst cmp al-tn end)
+ (if last
+ (inst jmp less-or-equal target)
+ (inst jmp :be when-true))))))) ; was :le
(emit-label drop-through))))
\f
(define-vop (simple-check-type)
(:args (value :target result :scs (any-reg descriptor-reg)))
(:results (result :scs (any-reg descriptor-reg)
- :load-if (not (and (sc-is value any-reg descriptor-reg)
- (sc-is result control-stack)))))
+ :load-if (not (and (sc-is value any-reg descriptor-reg)
+ (sc-is result control-stack)))))
(:vop-var vop)
(:save-p :compute-only))
(if (> (apply #'max type-codes) lowtag-limit) 7 2)))
(defmacro !define-type-vops (pred-name check-name ptype error-code
- (&rest type-codes)
- &key (variant nil variant-p) &allow-other-keys)
+ (&rest type-codes)
+ &key (variant nil variant-p) &allow-other-keys)
;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
;; expansion?
(let* ((cost (cost-to-test-types (mapcar #'eval type-codes)))
- (prefix (if variant-p
- (concatenate 'string (string variant) "-")
- "")))
+ (prefix (if variant-p
+ (concatenate 'string (string variant) "-")
+ "")))
`(progn
,@(when pred-name
- `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
- (:translate ,pred-name)
- (:generator ,cost
- (test-type value target not-p (,@type-codes))))))
+ `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value target not-p (,@type-codes))))))
,@(when check-name
- `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
- (:generator ,cost
- (let ((err-lab
- (generate-error-code vop ,error-code value)))
- (test-type value err-lab t (,@type-codes))
- (move result value))))))
+ `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
+ (:generator ,cost
+ (let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value err-lab t (,@type-codes))
+ (move result value))))))
,@(when ptype
- `((primitive-type-vop ,check-name (:check) ,ptype))))))
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
\f
;;;; other integer ranges
(inst jmp :ne (if not-p target NOT-TARGET))
(inst sar rax-tn (+ 32 3 -1))
(if not-p
- (progn
- (inst jmp :nz MAYBE)
- (inst jmp NOT-TARGET))
- (inst jmp :z target))
+ (progn
+ (inst jmp :nz MAYBE)
+ (inst jmp NOT-TARGET))
+ (inst jmp :z target))
MAYBE
(inst cmp rax-tn -1)
(inst jmp (if not-p :ne :eq) target)
(define-vop (check-signed-byte-32 check-type)
(:generator 8
(let ((nope (generate-error-code vop
- object-not-signed-byte-32-error
- value))
- (ok (gen-label)))
+ object-not-signed-byte-32-error
+ value))
+ (ok (gen-label)))
(move rax-tn value)
(inst test rax-tn 7)
(inst jmp :ne nope)
- (inst sar rax-tn (+ 32 3 -1))
+ (inst sar rax-tn (+ 32 3 -1))
(inst jmp :z ok)
(inst cmp rax-tn -1)
(inst jmp :ne nope)
(define-vop (check-unsigned-byte-32 check-type)
(:generator 8
(let ((nope
- (generate-error-code vop object-not-unsigned-byte-32-error value)))
+ (generate-error-code vop object-not-unsigned-byte-32-error value)))
(move rax-tn value)
(inst test rax-tn 7)
(inst jmp :ne nope)
(:translate unsigned-byte-64-p)
(:generator 45
(let ((not-target (gen-label))
- (single-word (gen-label))
- (fixnum (gen-label)))
+ (single-word (gen-label))
+ (fixnum (gen-label)))
(multiple-value-bind (yep nope)
- (if not-p
- (values not-target target)
- (values target not-target))
- ;; Is it a fixnum?
- (generate-fixnum-test value)
- (move rax-tn value)
- (inst jmp :e fixnum)
-
- ;; If not, is it an other pointer?
- (inst and rax-tn lowtag-mask)
- (inst cmp rax-tn other-pointer-lowtag)
- (inst jmp :ne nope)
- ;; Get the header.
- (loadw rax-tn value 0 other-pointer-lowtag)
- ;; Is it one?
- (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
- (inst jmp :e single-word)
- ;; If it's other than two, we can't be an (unsigned-byte 64)
- (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
- (inst jmp :ne nope)
- ;; Get the second digit.
- (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
- ;; All zeros, its an (unsigned-byte 64).
- (inst or rax-tn rax-tn)
- (inst jmp :z yep)
- (inst jmp nope)
-
- (emit-label single-word)
- ;; Get the single digit.
- (loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
-
- ;; positive implies (unsigned-byte 64).
- (emit-label fixnum)
- (inst or rax-tn rax-tn)
- (inst jmp (if not-p :s :ns) target)
-
- (emit-label not-target)))))
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ ;; Is it a fixnum?
+ (generate-fixnum-test value)
+ (move rax-tn value)
+ (inst jmp :e fixnum)
+
+ ;; If not, is it an other pointer?
+ (inst and rax-tn lowtag-mask)
+ (inst cmp rax-tn other-pointer-lowtag)
+ (inst jmp :ne nope)
+ ;; Get the header.
+ (loadw rax-tn value 0 other-pointer-lowtag)
+ ;; Is it one?
+ (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (inst jmp :e single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 64)
+ (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
+ (inst jmp :ne nope)
+ ;; Get the second digit.
+ (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
+ ;; All zeros, its an (unsigned-byte 64).
+ (inst or rax-tn rax-tn)
+ (inst jmp :z yep)
+ (inst jmp nope)
+
+ (emit-label single-word)
+ ;; Get the single digit.
+ (loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
+
+ ;; positive implies (unsigned-byte 64).
+ (emit-label fixnum)
+ (inst or rax-tn rax-tn)
+ (inst jmp (if not-p :s :ns) target)
+
+ (emit-label not-target)))))
(define-vop (check-unsigned-byte-64 check-type)
(:generator 45
(let ((nope
- (generate-error-code vop object-not-unsigned-byte-64-error value))
- (yep (gen-label))
- (fixnum (gen-label))
- (single-word (gen-label)))
+ (generate-error-code vop object-not-unsigned-byte-64-error value))
+ (yep (gen-label))
+ (fixnum (gen-label))
+ (single-word (gen-label)))
;; Is it a fixnum?
(generate-fixnum-test value)
(inst or rax-tn rax-tn)
(inst jmp :z yep)
(inst jmp nope)
-
+
(emit-label single-word)
;; Get the single digit.
(loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
(:results (start) (count))
(:info nvals)
(:generator 20
- (move temp rsp-tn) ; WARN pointing 1 below
+ (move temp rsp-tn) ; WARN pointing 1 below
(do ((val vals (tn-ref-across val)))
- ((null val))
+ ((null val))
(inst push (tn-ref-tn val)))
(move start temp)
(inst mov count (fixnumize nvals))))
(:arg-types list)
(:policy :fast-safe)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:temporary (:sc descriptor-reg :from (:argument 0) :to (:result 1)) list)
(:temporary (:sc descriptor-reg :to (:result 1)) nil-temp)
(:temporary (:sc unsigned-reg :offset rax-offset :to (:result 1)) rax)
(:save-p :compute-only)
(:generator 0
(move list arg)
- (move start rsp-tn) ; WARN pointing 1 below
+ (move start rsp-tn) ; WARN pointing 1 below
(inst mov nil-temp nil-value)
LOOP
(error-call vop bogus-arg-to-values-list-error list)
DONE
- (inst mov count start) ; start is high address
- (inst sub count rsp-tn))) ; stackp is low address
+ (inst mov count start) ; start is high address
+ (inst sub count rsp-tn))) ; stackp is low address
;;; Copy the more arg block to the top of the stack so we can use them
;;; as function arguments.
;;; defining a new stack frame.
(define-vop (%more-arg-values)
(:args (context :scs (descriptor-reg any-reg) :target src)
- (skip :scs (any-reg immediate))
- (num :scs (any-reg) :target count))
+ (skip :scs (any-reg immediate))
+ (num :scs (any-reg) :target count))
(:arg-types * positive-fixnum positive-fixnum)
(:temporary (:sc any-reg :offset rsi-offset :from (:argument 0)) src)
(:temporary (:sc descriptor-reg :offset rax-offset) temp)
(:temporary (:sc unsigned-reg :offset rcx-offset) temp1)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:generator 20
(sc-case skip
(immediate
(cond ((zerop (tn-value skip))
- (move src context)
- (move count num))
- (t
- (inst lea src (make-ea :dword :base context
- :disp (- (* (tn-value skip)
- n-word-bytes))))
- (move count num)
- (inst sub count (* (tn-value skip) n-word-bytes)))))
+ (move src context)
+ (move count num))
+ (t
+ (inst lea src (make-ea :dword :base context
+ :disp (- (* (tn-value skip)
+ n-word-bytes))))
+ (move count num)
+ (inst sub count (* (tn-value skip) n-word-bytes)))))
(any-reg
(move src context)
(defvar *float-register-names* (make-array 16 :initial-element nil)))
(macrolet ((defreg (name offset size)
- (let ((offset-sym (symbolicate name "-OFFSET"))
- (names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((offset-sym (symbolicate name "-OFFSET"))
+ (names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET
;; (in the same file) depends on compile-time evaluation
;; of the DEFCONSTANT. -- AL 20010224
- (def!constant ,offset-sym ,offset))
- (setf (svref ,names-vector ,offset-sym)
- ,(symbol-name name)))))
- ;; FIXME: It looks to me as though DEFREGSET should also
- ;; define the related *FOO-REGISTER-NAMES* variable.
- (defregset (name &rest regs)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter ,name
- (list ,@(mapcar (lambda (name)
- (symbolicate name "-OFFSET"))
- regs))))))
+ (def!constant ,offset-sym ,offset))
+ (setf (svref ,names-vector ,offset-sym)
+ ,(symbol-name name)))))
+ ;; FIXME: It looks to me as though DEFREGSET should also
+ ;; define the related *FOO-REGISTER-NAMES* variable.
+ (defregset (name &rest regs)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter ,name
+ (list ,@(mapcar (lambda (name)
+ (symbolicate name "-OFFSET"))
+ regs))))))
;; byte registers
;;
;; list of qword registers. However
;; <jsnell> r13 is already used as temporary [#lisp irc 2005/01/30]
;; and we're now going to use r12 for the struct thread*
- (defregset *qword-regs* rax rcx rdx rbx rsi rdi
- r8 r9 r10 r11 r14 r15)
+ (defregset *qword-regs* rax rcx rdx rbx rsi rdi
+ r8 r9 r10 r11 r14 r15)
;; floating point registers
(defreg float0 0 :float)
(defreg float14 14 :float)
(defreg float15 15 :float)
(defregset *float-regs* float0 float1 float2 float3 float4 float5 float6 float7
- float8 float9 float10 float11 float12 float13 float14 float15)
+ float8 float9 float10 float11 float12 float13 float14 float15)
;; registers used to pass arguments
;;
(collect ((forms))
(let ((index 0))
(dolist (class classes)
- (let* ((sc-name (car class))
- (constant-name (symbolicate sc-name "-SC-NUMBER")))
- (forms `(define-storage-class ,sc-name ,index
- ,@(cdr class)))
- (forms `(def!constant ,constant-name ,index))
- (incf index))))
+ (let* ((sc-name (car class))
+ (constant-name (symbolicate sc-name "-SC-NUMBER")))
+ (forms `(define-storage-class ,sc-name ,index
+ ,@(cdr class)))
+ (forms `(def!constant ,constant-name ,index))
+ (incf index))))
`(progn
,@(forms))))
;;
;; the stacks
;;
-
+
;; the control stack
- (control-stack stack) ; may be pointers, scanned by GC
+ (control-stack stack) ; may be pointers, scanned by GC
;; the non-descriptor stacks
;; XXX alpha backend has :element-size 2 :alignment 2 in these entries
- (signed-stack stack) ; (signed-byte 32)
- (unsigned-stack stack) ; (unsigned-byte 32)
- (character-stack stack) ; non-descriptor characters.
- (sap-stack stack) ; System area pointers.
- (single-stack stack) ; single-floats
+ (signed-stack stack) ; (signed-byte 32)
+ (unsigned-stack stack) ; (unsigned-byte 32)
+ (character-stack stack) ; non-descriptor characters.
+ (sap-stack stack) ; System area pointers.
+ (single-stack stack) ; single-floats
(double-stack stack)
- (complex-single-stack stack :element-size 2) ; complex-single-floats
- (complex-double-stack stack :element-size 2) ; complex-double-floats
+ (complex-single-stack stack :element-size 2) ; complex-single-floats
+ (complex-double-stack stack :element-size 2) ; complex-double-floats
;;
;; immediate descriptor objects. Don't have to be seen by GC, but nothing
;; bad will happen if they are. (fixnums, characters, header values, etc).
(any-reg registers
- :locations #.*qword-regs*
- :element-size 2 ; I think this is for the al/ah overlap thing
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (control-stack))
+ :locations #.*qword-regs*
+ :element-size 2 ; I think this is for the al/ah overlap thing
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (control-stack))
;; pointer descriptor objects -- must be seen by GC
(descriptor-reg registers
- :locations #.*qword-regs*
- :element-size 2
-; :reserve-locations (#.eax-offset)
- :constant-scs (constant immediate)
- :save-p t
- :alternate-scs (control-stack))
+ :locations #.*qword-regs*
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (constant immediate)
+ :save-p t
+ :alternate-scs (control-stack))
;; non-descriptor characters
(character-reg registers
- :locations #!-sb-unicode #.*byte-regs*
- #!+sb-unicode #.*qword-regs*
- #!-sb-unicode #!-sb-unicode
- :reserve-locations (#.al-offset)
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (character-stack))
+ :locations #!-sb-unicode #.*byte-regs*
+ #!+sb-unicode #.*qword-regs*
+ #!-sb-unicode #!-sb-unicode
+ :reserve-locations (#.al-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (character-stack))
;; non-descriptor SAPs (arbitrary pointers into address space)
(sap-reg registers
- :locations #.*qword-regs*
- :element-size 2
-; :reserve-locations (#.eax-offset)
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (sap-stack))
+ :locations #.*qword-regs*
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (sap-stack))
;; non-descriptor (signed or unsigned) numbers
(signed-reg registers
- :locations #.*qword-regs*
- :element-size 2
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (signed-stack))
+ :locations #.*qword-regs*
+ :element-size 2
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (signed-stack))
(unsigned-reg registers
- :locations #.*qword-regs*
- :element-size 2
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (unsigned-stack))
+ :locations #.*qword-regs*
+ :element-size 2
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (unsigned-stack))
;; miscellaneous objects that must not be seen by GC. Used only as
;; temporaries.
(word-reg registers
- :locations #.*word-regs*
- :element-size 2
- )
+ :locations #.*word-regs*
+ :element-size 2
+ )
(dword-reg registers
- :locations #.*dword-regs*
- :element-size 2
- )
+ :locations #.*dword-regs*
+ :element-size 2
+ )
(byte-reg registers
- :locations #.*byte-regs*
- )
+ :locations #.*byte-regs*
+ )
;; that can go in the floating point registers
;; non-descriptor SINGLE-FLOATs
(single-reg float-registers
- :locations #.(loop for i from 0 below 15 collect i)
- :constant-scs (fp-single-zero)
- :save-p t
- :alternate-scs (single-stack))
+ :locations #.(loop for i from 0 below 15 collect i)
+ :constant-scs (fp-single-zero)
+ :save-p t
+ :alternate-scs (single-stack))
;; non-descriptor DOUBLE-FLOATs
(double-reg float-registers
- :locations #.(loop for i from 0 below 15 collect i)
- :constant-scs (fp-double-zero)
- :save-p t
- :alternate-scs (double-stack))
+ :locations #.(loop for i from 0 below 15 collect i)
+ :constant-scs (fp-double-zero)
+ :save-p t
+ :alternate-scs (double-stack))
(complex-single-reg float-registers
- :locations #.(loop for i from 0 to 14 by 2 collect i)
- :element-size 2
- :constant-scs ()
- :save-p t
- :alternate-scs (complex-single-stack))
+ :locations #.(loop for i from 0 to 14 by 2 collect i)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-single-stack))
(complex-double-reg float-registers
- :locations #.(loop for i from 0 to 14 by 2 collect i)
- :element-size 2
- :constant-scs ()
- :save-p t
- :alternate-scs (complex-double-stack))
+ :locations #.(loop for i from 0 to 14 by 2 collect i)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-double-stack))
;; a catch or unwind block
(catch-block stack :element-size kludge-nondeterministic-catch-block-size))
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defparameter *byte-sc-names*
+(defparameter *byte-sc-names*
'(#!-sb-unicode character-reg byte-reg #!-sb-unicode character-stack))
(defparameter *word-sc-names* '(word-reg))
(defparameter *dword-sc-names* '(dword-reg))
-(defparameter *qword-sc-names*
+(defparameter *qword-sc-names*
'(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
- signed-stack unsigned-stack sap-stack single-stack
+ signed-stack unsigned-stack sap-stack single-stack
#!+sb-unicode character-reg #!+sb-unicode character-stack constant))
;;; added by jrd. I guess the right thing to do is to treat floats
;;; as a separate size...
;;;; miscellaneous TNs for the various registers
(macrolet ((def-misc-reg-tns (sc-name &rest reg-names)
- (collect ((forms))
- (dolist (reg-name reg-names)
- (let ((tn-name (symbolicate reg-name "-TN"))
- (offset-name (symbolicate reg-name "-OFFSET")))
- ;; FIXME: It'd be good to have the special
- ;; variables here be named with the *FOO*
- ;; convention.
- (forms `(defparameter ,tn-name
- (make-random-tn :kind :normal
- :sc (sc-or-lose ',sc-name)
- :offset
- ,offset-name)))))
- `(progn ,@(forms)))))
+ (collect ((forms))
+ (dolist (reg-name reg-names)
+ (let ((tn-name (symbolicate reg-name "-TN"))
+ (offset-name (symbolicate reg-name "-OFFSET")))
+ ;; FIXME: It'd be good to have the special
+ ;; variables here be named with the *FOO*
+ ;; convention.
+ (forms `(defparameter ,tn-name
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose ',sc-name)
+ :offset
+ ,offset-name)))))
+ `(progn ,@(forms)))))
(def-misc-reg-tns unsigned-reg rax rbx rcx rdx rbp rsp rdi rsi
- r8 r9 r10 r11 r12 r13 r14 r15)
+ r8 r9 r10 r11 r12 r13 r14 r15)
(def-misc-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi)
(def-misc-reg-tns word-reg ax bx cx dx bp sp di si)
(def-misc-reg-tns byte-reg al cl dl bl sil dil r8b r9b r10b
- r11b r14b r15b)
- (def-misc-reg-tns single-reg
+ r11b r14b r15b)
+ (def-misc-reg-tns single-reg
float0 float1 float2 float3 float4 float5 float6 float7
float8 float9 float10 float11 float12 float13 float14 float15))
;;; TNs for registers used to pass arguments
(defparameter *register-arg-tns*
(mapcar (lambda (register-arg-name)
- (symbol-value (symbolicate register-arg-name "-TN")))
- *register-arg-names*))
+ (symbol-value (symbolicate register-arg-name "-TN")))
+ *register-arg-names*))
(defparameter thread-base-tn
(make-random-tn :kind :normal :sc (sc-or-lose 'unsigned-reg )
- :offset r12-offset))
+ :offset r12-offset))
(defparameter fp-single-zero-tn
(make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset 15))
+ :sc (sc-or-lose 'single-reg)
+ :offset 15))
(defparameter fp-double-zero-tn
(make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset 15))
+ :sc (sc-or-lose 'double-reg)
+ :offset 15))
;;; If value can be represented as an immediate constant, then return
;;; the appropriate SC number, otherwise return NIL.
(!def-vm-support-routine immediate-constant-sc (value)
(typecase value
((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
- #-sb-xc-host system-area-pointer character)
+ #-sb-xc-host system-area-pointer character)
(sc-number-or-lose 'immediate))
(symbol
(when (static-symbol-p value)
(sc-number-or-lose 'immediate)))
(single-float
(if (eql value 0f0)
- (sc-number-or-lose 'fp-single-zero )
- nil))
+ (sc-number-or-lose 'fp-single-zero )
+ nil))
(double-float
(if (eql value 0d0)
- (sc-number-or-lose 'fp-double-zero )
- nil))))
+ (sc-number-or-lose 'fp-double-zero )
+ nil))))
\f
;;;; miscellaneous function call parameters
(!def-vm-support-routine location-print-name (tn)
(declare (type tn tn))
(let* ((sc (tn-sc tn))
- (sb (sb-name (sc-sb sc)))
- (offset (tn-offset tn)))
+ (sb (sb-name (sc-sb sc)))
+ (offset (tn-offset tn)))
(ecase sb
(registers
(let* ((sc-name (sc-name sc))
- (name-vec (cond ((member sc-name *byte-sc-names*)
- *byte-register-names*)
- ((member sc-name *word-sc-names*)
- *word-register-names*)
- ((member sc-name *dword-sc-names*)
- *dword-register-names*)
- ((member sc-name *qword-sc-names*)
- *qword-register-names*))))
- (or (and name-vec
- (< -1 offset (length name-vec))
- (svref name-vec offset))
- ;; FIXME: Shouldn't this be an ERROR?
- (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
+ (name-vec (cond ((member sc-name *byte-sc-names*)
+ *byte-register-names*)
+ ((member sc-name *word-sc-names*)
+ *word-register-names*)
+ ((member sc-name *dword-sc-names*)
+ *dword-register-names*)
+ ((member sc-name *qword-sc-names*)
+ *qword-register-names*))))
+ (or (and name-vec
+ (< -1 offset (length name-vec))
+ (svref name-vec offset))
+ ;; FIXME: Shouldn't this be an ERROR?
+ (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
(float-registers (format nil "FLOAT~D" offset))
(stack (format nil "S~D" offset))
(constant (format nil "Const~D" offset))
(defun dwords-for-quad (value)
(let* ((lo (logand value (1- (ash 1 32))))
- (hi (ash value -32)))
+ (hi (ash value -32)))
(values lo hi)))
(defun words-for-dword (value)
(let* ((lo (logand value (1- (ash 1 16))))
- (hi (ash value -16)))
+ (hi (ash value -16)))
(values lo hi)))
(def!constant cfp-offset rbp-offset) ; pfw - needed by stuff in /code
(:node-var node)
(:generator 0
(cond ((zerop num)
- ;; (move result nil-value)
- (inst mov result nil-value))
- ((and star (= num 1))
- (move result (tn-ref-tn things)))
- (t
- (macrolet
- ((store-car (tn list &optional (slot cons-car-slot))
- `(let ((reg
- (sc-case ,tn
- ((any-reg descriptor-reg) ,tn)
- ((control-stack)
- (move temp ,tn)
- temp))))
- (storew reg ,list ,slot list-pointer-lowtag))))
- (let ((cons-cells (if star (1- num) num)))
- (pseudo-atomic
- (allocation res (* (pad-data-block cons-size) cons-cells) node
+ ;; (move result nil-value)
+ (inst mov result nil-value))
+ ((and star (= num 1))
+ (move result (tn-ref-tn things)))
+ (t
+ (macrolet
+ ((store-car (tn list &optional (slot cons-car-slot))
+ `(let ((reg
+ (sc-case ,tn
+ ((any-reg descriptor-reg) ,tn)
+ ((control-stack)
+ (move temp ,tn)
+ temp))))
+ (storew reg ,list ,slot list-pointer-lowtag))))
+ (let ((cons-cells (if star (1- num) num)))
+ (pseudo-atomic
+ (allocation res (* (pad-data-block cons-size) cons-cells) node
(awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it)))
- (inst lea res
- (make-ea :byte :base res :disp list-pointer-lowtag))
- (move ptr res)
- (dotimes (i (1- cons-cells))
- (store-car (tn-ref-tn things) ptr)
- (setf things (tn-ref-across things))
- (inst add ptr (pad-data-block cons-size))
- (storew ptr ptr (- cons-cdr-slot cons-size)
- list-pointer-lowtag))
- (store-car (tn-ref-tn things) ptr)
- (cond (star
- (setf things (tn-ref-across things))
- (store-car (tn-ref-tn things) ptr cons-cdr-slot))
- (t
- (storew nil-value ptr cons-cdr-slot
- list-pointer-lowtag)))
- (aver (null (tn-ref-across things)))))
- (move result res))))))
+ (inst lea res
+ (make-ea :byte :base res :disp list-pointer-lowtag))
+ (move ptr res)
+ (dotimes (i (1- cons-cells))
+ (store-car (tn-ref-tn things) ptr)
+ (setf things (tn-ref-across things))
+ (inst add ptr (pad-data-block cons-size))
+ (storew ptr ptr (- cons-cdr-slot cons-size)
+ list-pointer-lowtag))
+ (store-car (tn-ref-tn things) ptr)
+ (cond (star
+ (setf things (tn-ref-across things))
+ (store-car (tn-ref-tn things) ptr cons-cdr-slot))
+ (t
+ (storew nil-value ptr cons-cdr-slot
+ list-pointer-lowtag)))
+ (aver (null (tn-ref-across things)))))
+ (move result res))))))
(define-vop (list list-or-list*)
(:variant nil))
'sb!vm::allocate-vector-on-heap))))
(dolist (arg args)
(setf (lvar-info arg)
- (make-ir2-lvar (primitive-type (lvar-type arg)))))
+ (make-ir2-lvar (primitive-type (lvar-type arg)))))
(unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
(ltn-default-call call)
(return-from allocate-vector-ltn-annotate-optimizer (values)))
;;;
(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg) :target boxed)
- (unboxed-arg :scs (any-reg) :target unboxed))
+ (unboxed-arg :scs (any-reg) :target unboxed))
(:results (result :scs (descriptor-reg) :from :eval))
(:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
(:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
(storew name result fdefn-name-slot other-pointer-lowtag)
(storew nil-value result fdefn-fun-slot other-pointer-lowtag)
(storew (make-fixup "undefined_tramp" :foreign)
- result fdefn-raw-addr-slot other-pointer-lowtag))))
+ result fdefn-raw-addr-slot other-pointer-lowtag))))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(:node-var node)
(:generator 10
(with-fixed-allocation
- (result value-cell-header-widetag value-cell-size node)
+ (result value-cell-header-widetag value-cell-size node)
(storew value result value-cell-value-slot other-pointer-lowtag))))
\f
;;;; automatic allocators for primitive objects
(inst lea result (make-ea :byte :base result :disp lowtag))
(when type
(storew (logior (ash (1- words) n-widetag-bits) type)
- result
- 0
- lowtag)))))
+ result
+ 0
+ lowtag)))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
(:node-var node)
(:generator 50
(inst lea bytes
- (make-ea :dword :base extra :disp (* (1+ words) n-word-bytes)))
+ (make-ea :dword :base extra :disp (* (1+ words) n-word-bytes)))
(inst mov header bytes)
(inst shl header (- n-widetag-bits 2)) ; w+1 to length field
- (inst lea header ; (w-1 << 8) | type
- (make-ea :dword :base header :disp (+ (ash -2 n-widetag-bits) type)))
+ (inst lea header ; (w-1 << 8) | type
+ (make-ea :dword :base header :disp (+ (ash -2 n-widetag-bits) type)))
(inst and bytes (lognot lowtag-mask))
(pseudo-atomic
(allocation result bytes node)
(define-vop (fast-fixnum-binop fast-safe-arith-op)
(:args (x :target r :scs (any-reg)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg)
- (sc-is r control-stack)
- (location= x r))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r))))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg) :from (:argument 0)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg)
- (sc-is r control-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r)))))
(:result-types tagged-num)
(:note "inline fixnum arithmetic"))
(define-vop (fast-unsigned-binop fast-safe-arith-op)
(:args (x :target r :scs (unsigned-reg)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r))))
- (y :scs (unsigned-reg unsigned-stack)))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg) :from (:argument 0)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic"))
(define-vop (fast-signed-binop fast-safe-arith-op)
(:args (x :target r :scs (signed-reg)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg)
- (sc-is r signed-stack)
- (location= x r))))
- (y :scs (signed-reg signed-stack)))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (sc-is r signed-stack)
+ (location= x r))))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg) :from (:argument 0)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg)
- (sc-is r signed-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (sc-is r signed-stack)
+ (location= x r)))))
(:result-types signed-num)
(:note "inline (signed-byte 32) arithmetic"))
(:info y)
(:arg-types tagged-num (:constant (signed-byte 30)))
(:results (r :scs (any-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types tagged-num)
(:note "inline fixnum arithmetic"))
(:info y)
(:arg-types unsigned-num (:constant (unsigned-byte 32)))
(:results (r :scs (unsigned-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic"))
(:info y)
(:arg-types signed-num (:constant (signed-byte 32)))
(:results (r :scs (signed-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types signed-num)
(:note "inline (signed-byte 32) arithmetic"))
(macrolet ((define-binop (translate untagged-penalty op)
- `(progn
- (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
- fast-fixnum-binop)
- (:translate ,translate)
- (:generator 2
- (move r x)
- (inst ,op r y)))
- (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
- fast-fixnum-binop-c)
- (:translate ,translate)
- (:generator 1
- (move r x)
- (inst ,op r (fixnumize y))))
- (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
- fast-signed-binop)
- (:translate ,translate)
- (:generator ,(1+ untagged-penalty)
- (move r x)
- (inst ,op r y)))
- (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
- fast-signed-binop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (move r x)
- (inst ,op r y)))
- (define-vop (,(symbolicate "FAST-"
- translate
- "/UNSIGNED=>UNSIGNED")
- fast-unsigned-binop)
- (:translate ,translate)
- (:generator ,(1+ untagged-penalty)
- (move r x)
- (inst ,op r y)))
- (define-vop (,(symbolicate 'fast-
- translate
- '-c/unsigned=>unsigned)
- fast-unsigned-binop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (move r x)
- ,(if (eq translate 'logand)
- ;; for the -C/UNSIGNED=>UNSIGNED VOP, this case
- ;; is optimized away as an identity somewhere
- ;; along the lines. However, this VOP is used in
- ;; -C/SIGNED=>UNSIGNED, below, when the
- ;; higher-level lisp code can't optimize away the
- ;; non-trivial identity.
- `(unless (= y #.(1- (ash 1 n-word-bits)))
- (inst ,op r y))
- `(inst ,op r y)))))))
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+ fast-fixnum-binop)
+ (:translate ,translate)
+ (:generator 2
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+ fast-fixnum-binop-c)
+ (:translate ,translate)
+ (:generator 1
+ (move r x)
+ (inst ,op r (fixnumize y))))
+ (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+ fast-signed-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+ fast-signed-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate "FAST-"
+ translate
+ "/UNSIGNED=>UNSIGNED")
+ fast-unsigned-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate 'fast-
+ translate
+ '-c/unsigned=>unsigned)
+ fast-unsigned-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (move r x)
+ ,(if (eq translate 'logand)
+ ;; for the -C/UNSIGNED=>UNSIGNED VOP, this case
+ ;; is optimized away as an identity somewhere
+ ;; along the lines. However, this VOP is used in
+ ;; -C/SIGNED=>UNSIGNED, below, when the
+ ;; higher-level lisp code can't optimize away the
+ ;; non-trivial identity.
+ `(unless (= y #.(1- (ash 1 n-word-bits)))
+ (inst ,op r y))
+ `(inst ,op r y)))))))
(define-binop - 4 sub)
(define-binop logand 2 and)
(define-binop logior 2 or)
(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
(:translate +)
(:args (x :scs (any-reg) :target r
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg)
- (sc-is r control-stack)
- (location= x r))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r))))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg) :from (:argument 0)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg)
- (sc-is r control-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r)))))
(:result-types tagged-num)
(:note "inline fixnum arithmetic")
(:generator 2
(cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
- (not (location= x r)))
- (inst lea r (make-ea :dword :base x :index y :scale 1)))
- (t
- (move r x)
- (inst add r y)))))
+ (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r y)))))
(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
(:translate +)
(:info y)
(:arg-types tagged-num (:constant (signed-byte 30)))
(:results (r :scs (any-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types tagged-num)
(:note "inline fixnum arithmetic")
(:generator 1
(cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)))
- (inst lea r (make-ea :dword :base x :disp (fixnumize y))))
- (t
- (move r x)
- (inst add r (fixnumize y))))))
+ (inst lea r (make-ea :dword :base x :disp (fixnumize y))))
+ (t
+ (move r x)
+ (inst add r (fixnumize y))))))
(define-vop (fast-+/signed=>signed fast-safe-arith-op)
(:translate +)
(:args (x :scs (signed-reg) :target r
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg)
- (sc-is r signed-stack)
- (location= x r))))
- (y :scs (signed-reg signed-stack)))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (sc-is r signed-stack)
+ (location= x r))))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg) :from (:argument 0)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg)
- (location= x r)))))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (location= x r)))))
(:result-types signed-num)
(:note "inline (signed-byte 32) arithmetic")
(:generator 5
(cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
- (not (location= x r)))
- (inst lea r (make-ea :dword :base x :index y :scale 1)))
- (t
- (move r x)
- (inst add r y)))))
+ (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r y)))))
;;;; Special logand cases: (logand signed unsigned) => unsigned
(define-vop (fast-logand/signed-unsigned=>unsigned
- fast-logand/unsigned=>unsigned)
+ fast-logand/unsigned=>unsigned)
(:args (x :target r :scs (signed-reg)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r))))
- (y :scs (unsigned-reg unsigned-stack)))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types signed-num unsigned-num))
(define-vop (fast-logand-c/signed-unsigned=>unsigned
- fast-logand-c/unsigned=>unsigned)
+ fast-logand-c/unsigned=>unsigned)
(:args (x :target r :scs (signed-reg signed-stack)))
(:arg-types signed-num (:constant (unsigned-byte 32))))
(define-vop (fast-logand/unsigned-signed=>unsigned
- fast-logand/unsigned=>unsigned)
+ fast-logand/unsigned=>unsigned)
(:args (x :target r :scs (unsigned-reg)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y signed-reg)
- (sc-is r unsigned-stack)
- (location= x r))))
- (y :scs (signed-reg signed-stack)))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y signed-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (signed-reg signed-stack)))
(:arg-types unsigned-num signed-num))
\f
(:info y)
(:arg-types signed-num (:constant (signed-byte 32)))
(:results (r :scs (signed-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types signed-num)
(:note "inline (signed-byte 32) arithmetic")
(:generator 4
(cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
- (not (location= x r)))
- (inst lea r (make-ea :dword :base x :disp y)))
- (t
- (move r x)
- (if (= y 1)
- (inst inc r)
- (inst add r y))))))
+ (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :disp y)))
+ (t
+ (move r x)
+ (if (= y 1)
+ (inst inc r)
+ (inst add r y))))))
(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
(:translate +)
(:args (x :scs (unsigned-reg) :target r
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r))))
- (y :scs (unsigned-reg unsigned-stack)))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg) :from (:argument 0)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg)
- (sc-is r unsigned-stack)
- (location= x r)))))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic")
(:generator 5
(cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
- (sc-is r unsigned-reg) (not (location= x r)))
- (inst lea r (make-ea :dword :base x :index y :scale 1)))
- (t
- (move r x)
- (inst add r y)))))
+ (sc-is r unsigned-reg) (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r y)))))
(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
(:translate +)
(:info y)
(:arg-types unsigned-num (:constant (unsigned-byte 32)))
(:results (r :scs (unsigned-reg)
- :load-if (not (location= x r))))
+ :load-if (not (location= x r))))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic")
(:generator 4
(cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
- (not (location= x r)))
- (inst lea r (make-ea :dword :base x :disp y)))
- (t
- (move r x)
- (if (= y 1)
- (inst inc r)
- (inst add r y))))))
+ (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :disp y)))
+ (t
+ (move r x)
+ (if (= y 1)
+ (inst inc r)
+ (inst add r y))))))
\f
;;;; multiplication and division
(:translate *)
;; We need different loading characteristics.
(:args (x :scs (any-reg) :target r)
- (y :scs (any-reg control-stack)))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg) :from (:argument 0)))
(:result-types tagged-num)
(:translate *)
;; We need different loading characteristics.
(:args (x :scs (signed-reg) :target r)
- (y :scs (signed-reg signed-stack)))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg) :from (:argument 0)))
(:result-types signed-num)
(define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
(:translate *)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg unsigned-stack)))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :target r
- :from (:argument 0) :to :result) eax)
+ :from (:argument 0) :to :result) eax)
(:temporary (:sc unsigned-reg :offset edx-offset
- :from :eval :to :result) edx)
+ :from :eval :to :result) edx)
(:ignore edx)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (any-reg) :target eax)
- (y :scs (any-reg control-stack)))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:temporary (:sc signed-reg :offset eax-offset :target quo
- :from (:argument 0) :to (:result 0)) eax)
+ :from (:argument 0) :to (:result 0)) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :target rem
- :from (:argument 0) :to (:result 1)) edx)
+ :from (:argument 0) :to (:result 1)) edx)
(:results (quo :scs (any-reg))
- (rem :scs (any-reg)))
+ (rem :scs (any-reg)))
(:result-types tagged-num tagged-num)
(:note "inline fixnum arithmetic")
(:vop-var vop)
(:generator 31
(let ((zero (generate-error-code vop division-by-zero-error x y)))
(if (sc-is y any-reg)
- (inst test y y) ; smaller instruction
- (inst cmp y 0))
+ (inst test y y) ; smaller instruction
+ (inst cmp y 0))
(inst jmp :eq zero))
(move eax x)
(inst cdq)
(inst idiv eax y)
(if (location= quo eax)
- (inst shl eax 2)
- (inst lea quo (make-ea :dword :index eax :scale 4)))
+ (inst shl eax 2)
+ (inst lea quo (make-ea :dword :index eax :scale 4)))
(move rem edx)))
(define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
(:info y)
(:arg-types tagged-num (:constant (signed-byte 30)))
(:temporary (:sc signed-reg :offset eax-offset :target quo
- :from :argument :to (:result 0)) eax)
+ :from :argument :to (:result 0)) eax)
(:temporary (:sc any-reg :offset edx-offset :target rem
- :from :eval :to (:result 1)) edx)
+ :from :eval :to (:result 1)) edx)
(:temporary (:sc any-reg :from :eval :to :result) y-arg)
(:results (quo :scs (any-reg))
- (rem :scs (any-reg)))
+ (rem :scs (any-reg)))
(:result-types tagged-num tagged-num)
(:note "inline fixnum arithmetic")
(:vop-var vop)
(inst mov y-arg (fixnumize y))
(inst idiv eax y-arg)
(if (location= quo eax)
- (inst shl eax 2)
- (inst lea quo (make-ea :dword :index eax :scale 4)))
+ (inst shl eax 2)
+ (inst lea quo (make-ea :dword :index eax :scale 4)))
(move rem edx)))
(define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg signed-stack)))
+ (y :scs (unsigned-reg signed-stack)))
(:arg-types unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :target quo
- :from (:argument 0) :to (:result 0)) eax)
+ :from (:argument 0) :to (:result 0)) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :target rem
- :from (:argument 0) :to (:result 1)) edx)
+ :from (:argument 0) :to (:result 1)) edx)
(:results (quo :scs (unsigned-reg))
- (rem :scs (unsigned-reg)))
+ (rem :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic")
(:vop-var vop)
(:generator 33
(let ((zero (generate-error-code vop division-by-zero-error x y)))
(if (sc-is y unsigned-reg)
- (inst test y y) ; smaller instruction
- (inst cmp y 0))
+ (inst test y y) ; smaller instruction
+ (inst cmp y 0))
(inst jmp :eq zero))
(move eax x)
(inst xor edx edx)
(:info y)
(:arg-types unsigned-num (:constant (unsigned-byte 32)))
(:temporary (:sc unsigned-reg :offset eax-offset :target quo
- :from :argument :to (:result 0)) eax)
+ :from :argument :to (:result 0)) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :target rem
- :from :eval :to (:result 1)) edx)
+ :from :eval :to (:result 1)) edx)
(:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
(:results (quo :scs (unsigned-reg))
- (rem :scs (unsigned-reg)))
+ (rem :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic")
(:vop-var vop)
(define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (signed-reg) :target eax)
- (y :scs (signed-reg signed-stack)))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:temporary (:sc signed-reg :offset eax-offset :target quo
- :from (:argument 0) :to (:result 0)) eax)
+ :from (:argument 0) :to (:result 0)) eax)
(:temporary (:sc signed-reg :offset edx-offset :target rem
- :from (:argument 0) :to (:result 1)) edx)
+ :from (:argument 0) :to (:result 1)) edx)
(:results (quo :scs (signed-reg))
- (rem :scs (signed-reg)))
+ (rem :scs (signed-reg)))
(:result-types signed-num signed-num)
(:note "inline (signed-byte 32) arithmetic")
(:vop-var vop)
(:generator 33
(let ((zero (generate-error-code vop division-by-zero-error x y)))
(if (sc-is y signed-reg)
- (inst test y y) ; smaller instruction
- (inst cmp y 0))
+ (inst test y y) ; smaller instruction
+ (inst cmp y 0))
(inst jmp :eq zero))
(move eax x)
(inst cdq)
(:info y)
(:arg-types signed-num (:constant (signed-byte 32)))
(:temporary (:sc signed-reg :offset eax-offset :target quo
- :from :argument :to (:result 0)) eax)
+ :from :argument :to (:result 0)) eax)
(:temporary (:sc signed-reg :offset edx-offset :target rem
- :from :eval :to (:result 1)) edx)
+ :from :eval :to (:result 1)) edx)
(:temporary (:sc signed-reg :from :eval :to :result) y-arg)
(:results (quo :scs (signed-reg))
- (rem :scs (signed-reg)))
+ (rem :scs (signed-reg)))
(:result-types signed-num signed-num)
(:note "inline (signed-byte 32) arithmetic")
(:vop-var vop)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (any-reg) :target result
- :load-if (not (and (sc-is number any-reg control-stack)
- (sc-is result any-reg control-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number any-reg control-stack)
+ (sc-is result any-reg control-stack)
+ (location= number result)))))
(:info amount)
(:arg-types tagged-num (:constant integer))
(:results (result :scs (any-reg)
- :load-if (not (and (sc-is number control-stack)
- (sc-is result control-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number control-stack)
+ (sc-is result control-stack)
+ (location= number result)))))
(:result-types tagged-num)
(:note "inline ASH")
(:generator 2
(cond ((and (= amount 1) (not (location= number result)))
- (inst lea result (make-ea :dword :index number :scale 2)))
- ((and (= amount 2) (not (location= number result)))
- (inst lea result (make-ea :dword :index number :scale 4)))
- ((and (= amount 3) (not (location= number result)))
- (inst lea result (make-ea :dword :index number :scale 8)))
- (t
- (move result number)
- (cond ((plusp amount)
- ;; We don't have to worry about overflow because of the
- ;; result type restriction.
- (inst shl result amount))
- (t
- ;; If the amount is greater than 31, only shift by 31. We
- ;; have to do this because the shift instructions only look
- ;; at the low five bits of the result.
- (inst sar result (min 31 (- amount)))
- ;; Fixnum correction.
- (inst and result #xfffffffc)))))))
+ (inst lea result (make-ea :dword :index number :scale 2)))
+ ((and (= amount 2) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 4)))
+ ((and (= amount 3) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 8)))
+ (t
+ (move result number)
+ (cond ((plusp amount)
+ ;; We don't have to worry about overflow because of the
+ ;; result type restriction.
+ (inst shl result amount))
+ (t
+ ;; If the amount is greater than 31, only shift by 31. We
+ ;; have to do this because the shift instructions only look
+ ;; at the low five bits of the result.
+ (inst sar result (min 31 (- amount)))
+ ;; Fixnum correction.
+ (inst and result #xfffffffc)))))))
(define-vop (fast-ash-left/fixnum=>fixnum)
(:translate ash)
(:args (number :scs (any-reg) :target result
- :load-if (not (and (sc-is number control-stack)
- (sc-is result control-stack)
- (location= number result))))
- (amount :scs (unsigned-reg) :target ecx))
+ :load-if (not (and (sc-is number control-stack)
+ (sc-is result control-stack)
+ (location= number result))))
+ (amount :scs (unsigned-reg) :target ecx))
(:arg-types tagged-num positive-fixnum)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (result :scs (any-reg) :from (:argument 0)
- :load-if (not (and (sc-is number control-stack)
- (sc-is result control-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number control-stack)
+ (sc-is result control-stack)
+ (location= number result)))))
(:result-types tagged-num)
(:policy :fast-safe)
(:note "inline ASH")
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (signed-reg) :target result
- :load-if (not (and (sc-is number signed-stack)
- (sc-is result signed-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number signed-stack)
+ (sc-is result signed-stack)
+ (location= number result)))))
(:info amount)
(:arg-types signed-num (:constant integer))
(:results (result :scs (signed-reg)
- :load-if (not (and (sc-is number signed-stack)
- (sc-is result signed-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number signed-stack)
+ (sc-is result signed-stack)
+ (location= number result)))))
(:result-types signed-num)
(:note "inline ASH")
(:generator 3
(cond ((and (= amount 1) (not (location= number result)))
- (inst lea result (make-ea :dword :index number :scale 2)))
- ((and (= amount 2) (not (location= number result)))
- (inst lea result (make-ea :dword :index number :scale 4)))
- ((and (= amount 3) (not (location= number result)))
- (inst lea result (make-ea :dword :index number :scale 8)))
- (t
- (move result number)
- (cond ((plusp amount) (inst shl result amount))
- (t (inst sar result (min 31 (- amount)))))))))
+ (inst lea result (make-ea :dword :index number :scale 2)))
+ ((and (= amount 2) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 4)))
+ ((and (= amount 3) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 8)))
+ (t
+ (move result number)
+ (cond ((plusp amount) (inst shl result amount))
+ (t (inst sar result (min 31 (- amount)))))))))
(define-vop (fast-ash-c/unsigned=>unsigned)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (unsigned-reg) :target result
- :load-if (not (and (sc-is number unsigned-stack)
- (sc-is result unsigned-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number unsigned-stack)
+ (sc-is result unsigned-stack)
+ (location= number result)))))
(:info amount)
(:arg-types unsigned-num (:constant integer))
(:results (result :scs (unsigned-reg)
- :load-if (not (and (sc-is number unsigned-stack)
- (sc-is result unsigned-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number unsigned-stack)
+ (sc-is result unsigned-stack)
+ (location= number result)))))
(:result-types unsigned-num)
(:note "inline ASH")
(:generator 3
(cond ((and (= amount 1) (not (location= number result)))
- (inst lea result (make-ea :dword :index number :scale 2)))
- ((and (= amount 2) (not (location= number result)))
- (inst lea result (make-ea :dword :index number :scale 4)))
- ((and (= amount 3) (not (location= number result)))
- (inst lea result (make-ea :dword :index number :scale 8)))
- (t
- (move result number)
- (cond ((< -32 amount 32)
+ (inst lea result (make-ea :dword :index number :scale 2)))
+ ((and (= amount 2) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 4)))
+ ((and (= amount 3) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 8)))
+ (t
+ (move result number)
+ (cond ((< -32 amount 32)
;; this code is used both in ASH and ASH-MOD32, so
;; be careful
(if (plusp amount)
(inst shl result amount)
(inst shr result (- amount))))
- (t (if (sc-is result unsigned-reg)
+ (t (if (sc-is result unsigned-reg)
(inst xor result result)
(inst mov result 0))))))))
(define-vop (fast-ash-left/signed=>signed)
(:translate ash)
(:args (number :scs (signed-reg) :target result
- :load-if (not (and (sc-is number signed-stack)
- (sc-is result signed-stack)
- (location= number result))))
- (amount :scs (unsigned-reg) :target ecx))
+ :load-if (not (and (sc-is number signed-stack)
+ (sc-is result signed-stack)
+ (location= number result))))
+ (amount :scs (unsigned-reg) :target ecx))
(:arg-types signed-num positive-fixnum)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (result :scs (signed-reg) :from (:argument 0)
- :load-if (not (and (sc-is number signed-stack)
- (sc-is result signed-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number signed-stack)
+ (sc-is result signed-stack)
+ (location= number result)))))
(:result-types signed-num)
(:policy :fast-safe)
(:note "inline ASH")
(define-vop (fast-ash-left/unsigned=>unsigned)
(:translate ash)
(:args (number :scs (unsigned-reg) :target result
- :load-if (not (and (sc-is number unsigned-stack)
- (sc-is result unsigned-stack)
- (location= number result))))
- (amount :scs (unsigned-reg) :target ecx))
+ :load-if (not (and (sc-is number unsigned-stack)
+ (sc-is result unsigned-stack)
+ (location= number result))))
+ (amount :scs (unsigned-reg) :target ecx))
(:arg-types unsigned-num positive-fixnum)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (result :scs (unsigned-reg) :from (:argument 0)
- :load-if (not (and (sc-is number unsigned-stack)
- (sc-is result unsigned-stack)
- (location= number result)))))
+ :load-if (not (and (sc-is number unsigned-stack)
+ (sc-is result unsigned-stack)
+ (location= number result)))))
(:result-types unsigned-num)
(:policy :fast-safe)
(:note "inline ASH")
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (signed-reg) :target result)
- (amount :scs (signed-reg) :target ecx))
+ (amount :scs (signed-reg) :target ecx))
(:arg-types signed-num signed-num)
(:results (result :scs (signed-reg) :from (:argument 0)))
(:result-types signed-num)
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (unsigned-reg) :target result)
- (amount :scs (signed-reg) :target ecx))
+ (amount :scs (signed-reg) :target ecx))
(:arg-types unsigned-num signed-num)
(:results (result :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num)
(defoptimizer (%lea derive-type) ((base index scale disp))
(when (and (constant-lvar-p scale)
- (constant-lvar-p disp))
+ (constant-lvar-p disp))
(let ((scale (lvar-value scale))
- (disp (lvar-value disp))
- (base-type (lvar-type base))
- (index-type (lvar-type index)))
+ (disp (lvar-value disp))
+ (base-type (lvar-type base))
+ (index-type (lvar-type index)))
(when (and (numeric-type-p base-type)
- (numeric-type-p index-type))
- (let ((base-lo (numeric-type-low base-type))
- (base-hi (numeric-type-high base-type))
- (index-lo (numeric-type-low index-type))
- (index-hi (numeric-type-high index-type)))
- (make-numeric-type :class 'integer
- :complexp :real
- :low (when (and base-lo index-lo)
- (+ base-lo (* index-lo scale) disp))
- :high (when (and base-hi index-hi)
- (+ base-hi (* index-hi scale) disp))))))))
+ (numeric-type-p index-type))
+ (let ((base-lo (numeric-type-low base-type))
+ (base-hi (numeric-type-high base-type))
+ (index-lo (numeric-type-low index-type))
+ (index-hi (numeric-type-high index-type)))
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :low (when (and base-lo index-lo)
+ (+ base-lo (* index-lo scale) disp))
+ :high (when (and base-hi index-hi)
+ (+ base-hi (* index-hi scale) disp))))))))
(defun %lea (base index scale disp)
(+ base (* index scale) disp))
(:translate %lea)
(:policy :fast-safe)
(:args (base :scs (unsigned-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:info scale disp)
(:arg-types unsigned-num unsigned-num
- (:constant (member 1 2 4 8))
- (:constant (signed-byte 32)))
+ (:constant (member 1 2 4 8))
+ (:constant (signed-byte 32)))
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 5
(inst lea r (make-ea :dword :base base :index index
- :scale scale :disp disp))))
+ :scale scale :disp disp))))
(define-vop (%lea/signed=>signed)
(:translate %lea)
(:policy :fast-safe)
(:args (base :scs (signed-reg))
- (index :scs (signed-reg)))
+ (index :scs (signed-reg)))
(:info scale disp)
(:arg-types signed-num signed-num
- (:constant (member 1 2 4 8))
- (:constant (signed-byte 32)))
+ (:constant (member 1 2 4 8))
+ (:constant (signed-byte 32)))
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:generator 4
(inst lea r (make-ea :dword :base base :index index
- :scale scale :disp disp))))
+ :scale scale :disp disp))))
(define-vop (%lea/fixnum=>fixnum)
(:translate %lea)
(:policy :fast-safe)
(:args (base :scs (any-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:info scale disp)
(:arg-types tagged-num tagged-num
- (:constant (member 1 2 4 8))
- (:constant (signed-byte 32)))
+ (:constant (member 1 2 4 8))
+ (:constant (signed-byte 32)))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:generator 3
(inst lea r (make-ea :dword :base base :index index
- :scale scale :disp disp))))
+ :scale scale :disp disp))))
;;; FIXME: before making knowledge of this too public, it needs to be
;;; fixed so that it's actually _faster_ than the non-CMOV version; at
(:translate ash)
(:policy :fast-safe)
(:args (number :scs (unsigned-reg) :target result)
- (amount :scs (signed-reg) :target ecx))
+ (amount :scs (signed-reg) :target ecx))
(:arg-types unsigned-num signed-num)
(:results (result :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num)
(inst cmp ecx 31)
(inst cmov :nbe result zero)
(inst jmp done)
-
+
POSITIVE
;; The result-type ensures us that this shift will not overflow.
(inst shl result :cl)
(define-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg))))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison"))
(define-vop (fast-conditional/signed fast-conditional)
(:args (x :scs (signed-reg)
- :load-if (not (and (sc-is x signed-stack)
- (sc-is y signed-reg))))
- (y :scs (signed-reg signed-stack)))
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg))))
+ (y :scs (signed-reg signed-stack)))
(:arg-types signed-num signed-num)
(:note "inline (signed-byte 32) comparison"))
(define-vop (fast-conditional/unsigned fast-conditional)
(:args (x :scs (unsigned-reg)
- :load-if (not (and (sc-is x unsigned-stack)
- (sc-is y unsigned-reg))))
- (y :scs (unsigned-reg unsigned-stack)))
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg))))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 32) comparison"))
(macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
- `(progn
- ,@(mapcar
- (lambda (suffix cost signed)
- `(define-vop (;; FIXME: These could be done more
- ;; cleanly with SYMBOLICATE.
- ,(intern (format nil "~:@(FAST-IF-~A~A~)"
- tran suffix))
- ,(intern
- (format nil "~:@(FAST-CONDITIONAL~A~)"
- suffix)))
- (:translate ,tran)
- (:generator ,cost
- (inst cmp x
- ,(if (eq suffix '-c/fixnum)
- '(fixnumize y)
- 'y))
- (inst jmp (if not-p
- ,(if signed
- not-cond
- not-unsigned)
- ,(if signed
- cond
- unsigned))
- target))))
- '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
- '(4 3 6 5 6 5)
- '(t t t t nil nil)))))
+ `(progn
+ ,@(mapcar
+ (lambda (suffix cost signed)
+ `(define-vop (;; FIXME: These could be done more
+ ;; cleanly with SYMBOLICATE.
+ ,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ tran suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,tran)
+ (:generator ,cost
+ (inst cmp x
+ ,(if (eq suffix '-c/fixnum)
+ '(fixnumize y)
+ 'y))
+ (inst jmp (if not-p
+ ,(if signed
+ not-cond
+ not-unsigned)
+ ,(if signed
+ cond
+ unsigned))
+ target))))
+ '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+ '(4 3 6 5 6 5)
+ '(t t t t nil nil)))))
(define-conditional-vop < :l :b :ge :ae)
(define-conditional-vop > :g :a :le :be))
(:translate eql)
(:generator 5
(cond ((and (sc-is x signed-reg) (zerop y))
- (inst test x x)) ; smaller instruction
- (t
- (inst cmp x y)))
+ (inst test x x)) ; smaller instruction
+ (t
+ (inst cmp x y)))
(inst jmp (if not-p :ne :e) target)))
(define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
(:translate eql)
(:generator 5
(cond ((and (sc-is x unsigned-reg) (zerop y))
- (inst test x x)) ; smaller instruction
- (t
- (inst cmp x y)))
+ (inst test x x)) ; smaller instruction
+ (t
+ (inst cmp x y)))
(inst jmp (if not-p :ne :e) target)))
;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
(define-vop (fast-eql/fixnum fast-conditional)
(:args (x :scs (any-reg)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg))))
+ (y :scs (any-reg control-stack)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison")
(:translate eql)
(inst jmp (if not-p :ne :e) target)))
(define-vop (generic-eql/fixnum fast-eql/fixnum)
(:args (x :scs (any-reg descriptor-reg)
- :load-if (not (and (sc-is x control-stack)
- (sc-is y any-reg))))
- (y :scs (any-reg control-stack)))
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg))))
+ (y :scs (any-reg control-stack)))
(:arg-types * tagged-num)
(:variant-cost 7))
(:translate eql)
(:generator 2
(cond ((and (sc-is x any-reg) (zerop y))
- (inst test x x)) ; smaller instruction
- (t
- (inst cmp x (fixnumize y))))
+ (inst test x x)) ; smaller instruction
+ (t
+ (inst cmp x (fixnumize y))))
(inst jmp (if not-p :ne :e) target)))
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
(:args (x :scs (any-reg descriptor-reg control-stack)))
(define-vop (merge-bits)
(:translate merge-bits)
(:args (shift :scs (signed-reg unsigned-reg) :target ecx)
- (prev :scs (unsigned-reg) :target result)
- (next :scs (unsigned-reg)))
+ (prev :scs (unsigned-reg) :target result)
+ (next :scs (unsigned-reg)))
(:arg-types tagged-num unsigned-num unsigned-num)
(:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
(:results (result :scs (unsigned-reg) :from (:argument 1)))
(define-vop (shift-towards-someplace)
(:policy :fast-safe)
(:args (num :scs (unsigned-reg) :target r)
- (amount :scs (signed-reg) :target ecx))
+ (amount :scs (signed-reg) :target ecx))
(:arg-types unsigned-num tagged-num)
(:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (r :scs (unsigned-reg) :from (:argument 0)))
(define-vop (fast-ash-left-mod32/unsigned=>unsigned
fast-ash-left/unsigned=>unsigned))
(deftransform ash-left-mod32 ((integer count)
- ((unsigned-byte 32) (unsigned-byte 5)))
+ ((unsigned-byte 32) (unsigned-byte 5)))
(when (sb!c::constant-lvar-p count)
(sb!c::give-up-ir1-transform))
'(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
(define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
(when (and (<= width 32)
- (constant-lvar-p scale)
- (constant-lvar-p disp))
+ (constant-lvar-p scale)
+ (constant-lvar-p disp))
(cut-to-width base :unsigned width)
(cut-to-width index :unsigned width)
'sb!vm::%lea-mod32))
(define-modular-fun-optimizer %lea ((base index scale disp) :signed :width width)
(when (and (<= width 30)
- (constant-lvar-p scale)
- (constant-lvar-p disp))
+ (constant-lvar-p scale)
+ (constant-lvar-p disp))
(cut-to-width base :signed width)
(cut-to-width index :signed width)
'sb!vm::%lea-smod30))
(in-package "SB!VM")
(define-vop (%lea-mod32/unsigned=>unsigned
- %lea/unsigned=>unsigned)
+ %lea/unsigned=>unsigned)
(:translate %lea-mod32))
(define-vop (%lea-smod30/fixnum=>fixnum
- %lea/fixnum=>fixnum)
+ %lea/fixnum=>fixnum)
(:translate %lea-smod30))
;;; logical operations
(define-vop (lognot-mod32/word=>unsigned)
(:translate lognot-mod32)
(:args (x :scs (unsigned-reg signed-reg unsigned-stack signed-stack) :target r
- :load-if (not (and (or (sc-is x unsigned-stack)
+ :load-if (not (and (or (sc-is x unsigned-stack)
(sc-is x signed-stack))
- (or (sc-is r unsigned-stack)
+ (or (sc-is r unsigned-stack)
(sc-is r signed-stack))
- (location= x r)))))
+ (location= x r)))))
(:arg-types unsigned-num)
(:results (r :scs (unsigned-reg)
- :load-if (not (and (or (sc-is x unsigned-stack)
+ :load-if (not (and (or (sc-is x unsigned-stack)
(sc-is x signed-stack))
(or (sc-is r unsigned-stack)
(sc-is r signed-stack))
- (sc-is r unsigned-stack)
- (location= x r)))))
+ (sc-is r unsigned-stack)
+ (location= x r)))))
(:result-types unsigned-num)
(:policy :fast-safe)
(:generator 1
(:translate sb!bignum:%add-with-carry)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg) :target result)
- (b :scs (unsigned-reg unsigned-stack) :to :eval)
- (c :scs (any-reg) :target temp))
+ (b :scs (unsigned-reg unsigned-stack) :to :eval)
+ (c :scs (any-reg) :target temp))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
(:results (result :scs (unsigned-reg) :from (:argument 0))
- (carry :scs (unsigned-reg)))
+ (carry :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 4
(move result a)
(:translate sb!bignum:%subtract-with-borrow)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg) :to :eval :target result)
- (b :scs (unsigned-reg unsigned-stack) :to :result)
- (c :scs (any-reg control-stack)))
+ (b :scs (unsigned-reg unsigned-stack) :to :result)
+ (c :scs (any-reg control-stack)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg) :from :eval)
- (borrow :scs (unsigned-reg)))
+ (borrow :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 5
(inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg unsigned-stack))
- (carry-in :scs (unsigned-reg unsigned-stack)))
+ (y :scs (unsigned-reg unsigned-stack))
+ (carry-in :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
- :to (:result 1) :target lo) eax)
+ :to (:result 1) :target lo) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
- :to (:result 0) :target hi) edx)
+ :to (:result 0) :target hi) edx)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 20
(move eax x)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg unsigned-stack))
- (prev :scs (unsigned-reg unsigned-stack))
- (carry-in :scs (unsigned-reg unsigned-stack)))
+ (y :scs (unsigned-reg unsigned-stack))
+ (prev :scs (unsigned-reg unsigned-stack))
+ (carry-in :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
- :to (:result 1) :target lo) eax)
+ :to (:result 1) :target lo) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
- :to (:result 0) :target hi) edx)
+ :to (:result 0) :target hi) edx)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 20
(move eax x)
(:translate sb!bignum:%multiply)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :target eax)
- (y :scs (unsigned-reg unsigned-stack)))
+ (y :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
- :to (:result 1) :target lo) eax)
+ :to (:result 1) :target lo) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
- :to (:result 0) :target hi) edx)
+ :to (:result 0) :target hi) edx)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 20
(move eax x)
(:args (fixnum :scs (any-reg control-stack) :target digit))
(:arg-types tagged-num)
(:results (digit :scs (unsigned-reg)
- :load-if (not (and (sc-is fixnum control-stack)
- (sc-is digit unsigned-stack)
- (location= fixnum digit)))))
+ :load-if (not (and (sc-is fixnum control-stack)
+ (sc-is digit unsigned-stack)
+ (location= fixnum digit)))))
(:result-types unsigned-num)
(:generator 1
(move digit fixnum)
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (div-high :scs (unsigned-reg) :target edx)
- (div-low :scs (unsigned-reg) :target eax)
- (divisor :scs (unsigned-reg unsigned-stack)))
+ (div-low :scs (unsigned-reg) :target eax)
+ (divisor :scs (unsigned-reg unsigned-stack)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
- :to (:result 0) :target quo) eax)
+ :to (:result 0) :target quo) eax)
(:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
- :to (:result 1) :target rem) edx)
+ :to (:result 1) :target rem) edx)
(:results (quo :scs (unsigned-reg))
- (rem :scs (unsigned-reg)))
+ (rem :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 300
(move edx div-high)
(:args (digit :scs (unsigned-reg unsigned-stack) :target res))
(:arg-types unsigned-num)
(:results (res :scs (any-reg signed-reg)
- :load-if (not (and (sc-is digit unsigned-stack)
- (sc-is res control-stack signed-stack)
- (location= digit res)))))
+ :load-if (not (and (sc-is digit unsigned-stack)
+ (sc-is res control-stack signed-stack)
+ (location= digit res)))))
(:result-types signed-num)
(:generator 1
(move res digit)
(:translate sb!bignum:%ashr)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg unsigned-stack) :target result)
- (count :scs (unsigned-reg) :target ecx))
+ (count :scs (unsigned-reg) :target ecx))
(:arg-types unsigned-num positive-fixnum)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:results (result :scs (unsigned-reg) :from (:argument 0)
- :load-if (not (and (sc-is result unsigned-stack)
- (location= digit result)))))
+ :load-if (not (and (sc-is result unsigned-stack)
+ (location= digit result)))))
(:result-types unsigned-num)
(:generator 1
(move result digit)
(:arg-types simple-array-unsigned-byte-32)
(:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k)
(:temporary (:sc unsigned-reg :offset eax-offset
- :from (:eval 0) :to :result) tmp)
+ :from (:eval 0) :to :result) tmp)
(:results (y :scs (unsigned-reg) :from (:eval 0)))
(:result-types unsigned-num)
(:generator 50
(inst mov k (make-ea :dword :base state
- :disp (- (* (+ 2 vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag)))
+ :disp (- (* (+ 2 vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag)))
(inst cmp k 624)
(inst jmp :ne no-update)
- (inst mov tmp state) ; The state is passed in EAX.
+ (inst mov tmp state) ; The state is passed in EAX.
(inst call (make-fixup 'random-mt19937-update :assembly-routine))
;; Restore k, and set to 0.
(inst xor k k)
NO-UPDATE
;; y = ptgfsr[k++];
(inst mov y (make-ea :dword :base state :index k :scale 4
- :disp (- (* (+ 3 vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag)))
+ :disp (- (* (+ 3 vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag)))
;; y ^= (y >> 11);
(inst shr y 11)
(inst xor y (make-ea :dword :base state :index k :scale 4
- :disp (- (* (+ 3 vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag)))
+ :disp (- (* (+ 3 vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag)))
;; y ^= (y << 7) & #x9d2c5680
(inst mov tmp y)
(inst inc k)
(inst shl tmp 7)
(inst mov (make-ea :dword :base state
- :disp (- (* (+ 2 vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag))
- k)
+ :disp (- (* (+ 2 vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag))
+ k)
(inst and tmp #x9d2c5680)
(inst xor y tmp)
;; y ^= (y << 15) & #xefc60000
,arg
,(ash 1 r0) 0))))
(t (let ((r0 (aref condensed 0)))
- (setf (aref condensed 0) 0)
- (mask-result class width
+ (setf (aref condensed 0) 0)
+ (mask-result class width
`(ash ,(decompose-multiplication class width
arg (ash num (- r0)) n-bits condensed)
,r0))))))
(mask-result class width `(ash ,arg ,(1- (integer-length num)))))
((let ((max 0) (end 0))
(loop for i from 2 to (length condensed)
- for j = (reduce #'+ (subseq condensed 0 i))
- when (and (> (- (* 2 i) 3 j) max)
- (< (+ (ash 1 (1+ j))
- (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num)
- (1+ j)))
- (ash 1 32)))
- do (setq max (- (* 2 i) 3 j)
- end i))
+ for j = (reduce #'+ (subseq condensed 0 i))
+ when (and (> (- (* 2 i) 3 j) max)
+ (< (+ (ash 1 (1+ j))
+ (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num)
+ (1+ j)))
+ (ash 1 32)))
+ do (setq max (- (* 2 i) 3 j)
+ end i))
(when (> max 0)
- (let ((j (reduce #'+ (subseq condensed 0 end))))
- (let ((n2 (+ (ash 1 (1+ j))
- (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num) (1+ j))))
- (n1 (1+ (ldb (byte (1+ j) 0) (lognot num)))))
- (mask-result class width
+ (let ((j (reduce #'+ (subseq condensed 0 end))))
+ (let ((n2 (+ (ash 1 (1+ j))
+ (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num) (1+ j))))
+ (n1 (1+ (ldb (byte (1+ j) 0) (lognot num)))))
+ (mask-result class width
`(- ,(optimize-multiply class width arg n2)
,(optimize-multiply class width arg n1))))))))
((dolist (i '(9 5 3))
(when (integerp (/ num i))
- (when (< (logcount (/ num i)) (logcount num))
- (let ((x (gensym)))
- (return `(let ((,x ,(optimize-multiply class width arg (/ num i))))
- ,(mask-result class width
+ (when (< (logcount (/ num i)) (logcount num))
+ (let ((x (gensym)))
+ (return `(let ((,x ,(optimize-multiply class width arg (/ num i))))
+ ,(mask-result class width
`(%lea ,x ,x (1- ,i) 0)))))))))
(t (basic-decompose-multiplication class width arg num n-bits condensed))))
(defun optimize-multiply (class width arg x)
(let* ((n-bits (logcount x))
- (condensed (make-array n-bits)))
+ (condensed (make-array n-bits)))
(let ((count 0) (bit 0))
(dotimes (i 32)
- (cond ((logbitp i x)
- (setf (aref condensed bit) count)
- (setf count 1)
- (incf bit))
- (t (incf count)))))
+ (cond ((logbitp i x)
+ (setf (aref condensed bit) count)
+ (setf count 1)
+ (incf bit))
+ (t (incf count)))))
(decompose-multiplication class width arg x n-bits condensed)))
(defun *-transformer (class width y)
(t (optimize-multiply class width 'x y))))
(deftransform * ((x y)
- ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
- (unsigned-byte 32))
+ ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
+ (unsigned-byte 32))
"recode as leas, shifts and adds"
(let ((y (lvar-value y)))
(*-transformer :unsigned 32 y)))
(*-transformer :unsigned 32 y)))
(deftransform * ((x y)
- ((signed-byte 30) (constant-arg (unsigned-byte 32)))
- (signed-byte 30))
+ ((signed-byte 30) (constant-arg (unsigned-byte 32)))
+ (signed-byte 30))
"recode as leas, shifts and adds"
(let ((y (lvar-value y)))
(*-transformer :signed 30 y)))
(:translate make-array-header)
(:policy :fast-safe)
(:args (type :scs (any-reg))
- (rank :scs (any-reg)))
+ (rank :scs (any-reg)))
(:arg-types positive-fixnum positive-fixnum)
(:temporary (:sc any-reg :to :eval) bytes)
(:temporary (:sc any-reg :to :result) header)
(:node-var node)
(:generator 13
(inst lea bytes
- (make-ea :dword :base rank
- :disp (+ (* (1+ array-dimensions-offset) n-word-bytes)
- lowtag-mask)))
+ (make-ea :dword :base rank
+ :disp (+ (* (1+ array-dimensions-offset) n-word-bytes)
+ lowtag-mask)))
(inst and bytes (lognot lowtag-mask))
(inst lea header (make-ea :dword :base rank
- :disp (fixnumize (1- array-dimensions-offset))))
+ :disp (fixnumize (1- array-dimensions-offset))))
(inst shl header n-widetag-bits)
(inst or header type)
(inst shr header 2)
(:translate %check-bound)
(:policy :fast-safe)
(:args (array :scs (descriptor-reg))
- (bound :scs (any-reg))
- (index :scs (any-reg #+nil immediate) :target result))
+ (bound :scs (any-reg))
+ (index :scs (any-reg #+nil immediate) :target result))
(:arg-types * positive-fixnum tagged-num)
(:results (result :scs (any-reg)))
(:result-types positive-fixnum)
(:save-p :compute-only)
(:generator 5
(let ((error (generate-error-code vop invalid-array-index-error
- array bound index))
- (index (if (sc-is index immediate)
- (fixnumize (tn-value index))
- index)))
+ array bound index))
+ (index (if (sc-is index immediate)
+ (fixnumize (tn-value index))
+ index)))
(inst cmp bound index)
;; We use below-or-equal even though it's an unsigned test,
;; because negative indexes appear as large unsigned numbers.
;; Therefore, we get the <0 and >=bound test all rolled into one.
(inst jmp :be error)
(unless (and (tn-p index) (location= result index))
- (inst mov result index)))))
+ (inst mov result index)))))
\f
;;;; accessors/setters
;;; whose elements are represented in integer registers and are built
;;; out of 8, 16, or 32 bit elements.
(macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
- `(progn
- (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
- ,type vector-data-offset other-pointer-lowtag ,scs
- ,element-type data-vector-ref)
- (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
- ,type vector-data-offset other-pointer-lowtag ,scs
- ,element-type data-vector-set))))
+ `(progn
+ (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
+ ,type vector-data-offset other-pointer-lowtag ,scs
+ ,element-type data-vector-ref)
+ (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
+ ,type vector-data-offset other-pointer-lowtag ,scs
+ ,element-type data-vector-set))))
(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
unsigned-reg)
;;;; bit, 2-bit, and 4-bit vectors
(macrolet ((def-small-data-vector-frobs (type bits)
- (let* ((elements-per-word (floor n-word-bits bits))
- (bit-shift (1- (integer-length elements-per-word))))
+ (let* ((elements-per-word (floor n-word-bits bits))
+ (bit-shift (1- (integer-length elements-per-word))))
`(progn
(define-vop (,(symbolicate 'data-vector-ref/ type))
- (:note "inline array access")
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
- (:arg-types ,type positive-fixnum)
- (:results (result :scs (unsigned-reg) :from (:argument 0)))
- (:result-types positive-fixnum)
- (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
- (:generator 20
- (move ecx index)
- (inst shr ecx ,bit-shift)
- (inst mov result
- (make-ea :dword :base object :index ecx :scale 4
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (move ecx index)
- (inst and ecx ,(1- elements-per-word))
- ,@(unless (= bits 1)
- `((inst shl ecx ,(1- (integer-length bits)))))
- (inst shr result :cl)
- (inst and result ,(1- (ash 1 bits)))))
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (result :scs (unsigned-reg) :from (:argument 0)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
+ (:generator 20
+ (move ecx index)
+ (inst shr ecx ,bit-shift)
+ (inst mov result
+ (make-ea :dword :base object :index ecx :scale 4
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
+ (move ecx index)
+ (inst and ecx ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst shl ecx ,(1- (integer-length bits)))))
+ (inst shr result :cl)
+ (inst and result ,(1- (ash 1 bits)))))
(define-vop (,(symbolicate 'data-vector-ref-c/ type))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:arg-types ,type (:constant index))
- (:info index)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:generator 15
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- (loadw result object (+ word vector-data-offset)
- other-pointer-lowtag)
- (unless (zerop extra)
- (inst shr result (* extra ,bits)))
- (unless (= extra ,(1- elements-per-word))
- (inst and result ,(1- (ash 1 bits)))))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:arg-types ,type (:constant index))
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 15
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (loadw result object (+ word vector-data-offset)
+ other-pointer-lowtag)
+ (unless (zerop extra)
+ (inst shr result (* extra ,bits)))
+ (unless (= extra ,(1- elements-per-word))
+ (inst and result ,(1- (ash 1 bits)))))))
(define-vop (,(symbolicate 'data-vector-set/ type))
- (:note "inline array store")
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :target ptr)
- (index :scs (unsigned-reg) :target ecx)
- (value :scs (unsigned-reg immediate) :target result))
- (:arg-types ,type positive-fixnum positive-fixnum)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:sc unsigned-reg) word-index)
- (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
- (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
- ecx)
- (:generator 25
- (move word-index index)
- (inst shr word-index ,bit-shift)
- (inst lea ptr
- (make-ea :dword :base object :index word-index :scale 4
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
- (loadw old ptr)
- (move ecx index)
- (inst and ecx ,(1- elements-per-word))
- ,@(unless (= bits 1)
- `((inst shl ecx ,(1- (integer-length bits)))))
- (inst ror old :cl)
- (unless (and (sc-is value immediate)
- (= (tn-value value) ,(1- (ash 1 bits))))
- (inst and old ,(lognot (1- (ash 1 bits)))))
- (sc-case value
- (immediate
- (unless (zerop (tn-value value))
- (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
- (unsigned-reg
- (inst or old value)))
- (inst rol old :cl)
- (storew old ptr)
- (sc-case value
- (immediate
- (inst mov result (tn-value value)))
- (unsigned-reg
- (move result value)))))
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :target ptr)
+ (index :scs (unsigned-reg) :target ecx)
+ (value :scs (unsigned-reg immediate) :target result))
+ (:arg-types ,type positive-fixnum positive-fixnum)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg) word-index)
+ (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
+ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
+ ecx)
+ (:generator 25
+ (move word-index index)
+ (inst shr word-index ,bit-shift)
+ (inst lea ptr
+ (make-ea :dword :base object :index word-index :scale 4
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
+ (loadw old ptr)
+ (move ecx index)
+ (inst and ecx ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst shl ecx ,(1- (integer-length bits)))))
+ (inst ror old :cl)
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (inst and old ,(lognot (1- (ash 1 bits)))))
+ (sc-case value
+ (immediate
+ (unless (zerop (tn-value value))
+ (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
+ (unsigned-reg
+ (inst or old value)))
+ (inst rol old :cl)
+ (storew old ptr)
+ (sc-case value
+ (immediate
+ (inst mov result (tn-value value)))
+ (unsigned-reg
+ (move result value)))))
(define-vop (,(symbolicate 'data-vector-set-c/ type))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (value :scs (unsigned-reg immediate) :target result))
- (:arg-types ,type (:constant index) positive-fixnum)
- (:info index)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:sc unsigned-reg :to (:result 0)) old)
- (:generator 20
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- (inst mov old
- (make-ea :dword :base object
- :disp (- (* (+ word vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag)))
- (sc-case value
- (immediate
- (let* ((value (tn-value value))
- (mask ,(1- (ash 1 bits)))
- (shift (* extra ,bits)))
- (unless (= value mask)
- (inst and old (ldb (byte n-word-bits 0)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg immediate) :target result))
+ (:arg-types ,type (:constant index) positive-fixnum)
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg :to (:result 0)) old)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (inst mov old
+ (make-ea :dword :base object
+ :disp (- (* (+ word vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (sc-case value
+ (immediate
+ (let* ((value (tn-value value))
+ (mask ,(1- (ash 1 bits)))
+ (shift (* extra ,bits)))
+ (unless (= value mask)
+ (inst and old (ldb (byte n-word-bits 0)
(lognot (ash mask shift)))))
- (unless (zerop value)
- (inst or old (ash value shift)))))
- (unsigned-reg
- (let ((shift (* extra ,bits)))
- (unless (zerop shift)
- (inst ror old shift))
+ (unless (zerop value)
+ (inst or old (ash value shift)))))
+ (unsigned-reg
+ (let ((shift (* extra ,bits)))
+ (unless (zerop shift)
+ (inst ror old shift))
(inst and old (lognot ,(1- (ash 1 bits))))
(inst or old value)
- (unless (zerop shift)
+ (unless (zerop shift)
(inst rol old shift)))))
- (inst mov (make-ea :dword :base object
- :disp (- (* (+ word vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag))
- old)
- (sc-case value
- (immediate
- (inst mov result (tn-value value)))
- (unsigned-reg
- (move result value))))))))))
+ (inst mov (make-ea :dword :base object
+ :disp (- (* (+ word vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag))
+ old)
+ (sc-case value
+ (immediate
+ (inst mov result (tn-value value)))
+ (unsigned-reg
+ (move result value))))))))))
(def-small-data-vector-frobs simple-bit-vector 1)
(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
(def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-single-float positive-fixnum)
(:results (value :scs (single-reg)))
(:result-types single-float)
(:generator 5
(with-empty-tn@fp-top(value)
- (inst fld (make-ea :dword :base object :index index :scale 1
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag))))))
+ (inst fld (make-ea :dword :base object :index index :scale 1
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag))))))
(define-vop (data-vector-ref-c/simple-array-single-float)
(:note "inline array access")
(:result-types single-float)
(:generator 4
(with-empty-tn@fp-top(value)
- (inst fld (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 4 index))
- other-pointer-lowtag))))))
+ (inst fld (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag))))))
(define-vop (data-vector-set/simple-array-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (single-reg) :target result))
(:arg-types simple-array-single-float positive-fixnum single-float)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 5
(cond ((zerop (tn-offset value))
- ;; Value is in ST0.
- (inst fst (make-ea :dword :base object :index index :scale 1
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fst result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (inst fst (make-ea :dword :base object :index index :scale 1
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fst value))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value result)
- (inst fst result))
- (inst fxch value)))))))
+ ;; Value is in ST0.
+ (inst fst (make-ea :dword :base object :index index :scale 1
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fst result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fst (make-ea :dword :base object :index index :scale 1
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fst value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fst result))
+ (inst fxch value)))))))
(define-vop (data-vector-set-c/simple-array-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs (single-reg) :target result))
+ (value :scs (single-reg) :target result))
(:info index)
(:arg-types simple-array-single-float (:constant (signed-byte 30))
- single-float)
+ single-float)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 4
(cond ((zerop (tn-offset value))
- ;; Value is in ST0.
- (inst fst (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 4 index))
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fst result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (inst fst (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 4 index))
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fst value))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value result)
- (inst fst result))
- (inst fxch value)))))))
+ ;; Value is in ST0.
+ (inst fst (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fst result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fst (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 4 index))
+ other-pointer-lowtag)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fst value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fst result))
+ (inst fxch value)))))))
(define-vop (data-vector-ref/simple-array-double-float)
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-double-float positive-fixnum)
(:results (value :scs (double-reg)))
(:result-types double-float)
(:generator 7
(with-empty-tn@fp-top(value)
(inst fldd (make-ea :dword :base object :index index :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag))))))
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag))))))
(define-vop (data-vector-ref-c/simple-array-double-float)
(:note "inline array access")
(:generator 6
(with-empty-tn@fp-top(value)
(inst fldd (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag))))))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag))))))
(define-vop (data-vector-set/simple-array-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (double-reg) :target result))
(:arg-types simple-array-double-float positive-fixnum double-float)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 20
(cond ((zerop (tn-offset value))
- ;; Value is in ST0.
- (inst fstd (make-ea :dword :base object :index index :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fstd result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (inst fstd (make-ea :dword :base object :index index :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fstd value))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value result)
- (inst fstd result))
- (inst fxch value)))))))
+ ;; Value is in ST0.
+ (inst fstd (make-ea :dword :base object :index index :scale 2
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fstd (make-ea :dword :base object :index index :scale 2
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
(define-vop (data-vector-set-c/simple-array-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs (double-reg) :target result))
+ (value :scs (double-reg) :target result))
(:info index)
(:arg-types simple-array-double-float (:constant (signed-byte 30))
- double-float)
+ double-float)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 19
(cond ((zerop (tn-offset value))
- ;; Value is in ST0.
- (inst fstd (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fstd result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (inst fstd (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fstd value))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value result)
- (inst fstd result))
- (inst fxch value)))))))
+ ;; Value is in ST0.
+ (inst fstd (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fstd (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-complex-single-float positive-fixnum)
(:results (value :scs (complex-single-reg)))
(:result-types complex-single-float)
(:generator 5
(let ((real-tn (complex-single-reg-real-tn value)))
(with-empty-tn@fp-top (real-tn)
- (inst fld (make-ea :dword :base object :index index :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))))
+ (inst fld (make-ea :dword :base object :index index :scale 2
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
- (inst fld (make-ea :dword :base object :index index :scale 2
- :disp (- (* (1+ vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag)))))))
+ (inst fld (make-ea :dword :base object :index index :scale 2
+ :disp (- (* (1+ vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag)))))))
(define-vop (data-vector-ref-c/simple-array-complex-single-float)
(:note "inline array access")
(:generator 4
(let ((real-tn (complex-single-reg-real-tn value)))
(with-empty-tn@fp-top (real-tn)
- (inst fld (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag)))))
+ (inst fld (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag)))))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
- (inst fld (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index) 4)
- other-pointer-lowtag)))))))
+ (inst fld (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index) 4)
+ other-pointer-lowtag)))))))
(define-vop (data-vector-set/simple-array-complex-single-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-single-reg) :target result))
(:arg-types simple-array-complex-single-float positive-fixnum
- complex-single-float)
+ complex-single-float)
(:results (result :scs (complex-single-reg)))
(:result-types complex-single-float)
(:generator 5
(let ((value-real (complex-single-reg-real-tn value))
- (result-real (complex-single-reg-real-tn result)))
+ (result-real (complex-single-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (inst fst (make-ea :dword :base object :index index :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fst result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (inst fst (make-ea :dword :base object :index index :scale 2
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fst value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fst result-real))
- (inst fxch value-real))))))
+ ;; Value is in ST0.
+ (inst fst (make-ea :dword :base object :index index :scale 2
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fst result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fst (make-ea :dword :base object :index index :scale 2
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fst value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fst result-real))
+ (inst fxch value-real))))))
(let ((value-imag (complex-single-reg-imag-tn value))
- (result-imag (complex-single-reg-imag-tn result)))
+ (result-imag (complex-single-reg-imag-tn result)))
(inst fxch value-imag)
(inst fst (make-ea :dword :base object :index index :scale 2
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- 4)
- other-pointer-lowtag)))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ 4)
+ other-pointer-lowtag)))
(unless (location= value-imag result-imag)
- (inst fst result-imag))
+ (inst fst result-imag))
(inst fxch value-imag))))
(define-vop (data-vector-set-c/simple-array-complex-single-float)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs (complex-single-reg) :target result))
+ (value :scs (complex-single-reg) :target result))
(:info index)
(:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
- complex-single-float)
+ complex-single-float)
(:results (result :scs (complex-single-reg)))
(:result-types complex-single-float)
(:generator 4
(let ((value-real (complex-single-reg-real-tn value))
- (result-real (complex-single-reg-real-tn result)))
+ (result-real (complex-single-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (inst fst (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fst result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (inst fst (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index))
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fst value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fst result-real))
- (inst fxch value-real))))))
+ ;; Value is in ST0.
+ (inst fst (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fst result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fst (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index))
+ other-pointer-lowtag)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fst value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fst result-real))
+ (inst fxch value-real))))))
(let ((value-imag (complex-single-reg-imag-tn value))
- (result-imag (complex-single-reg-imag-tn result)))
+ (result-imag (complex-single-reg-imag-tn result)))
(inst fxch value-imag)
(inst fst (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 8 index) 4)
- other-pointer-lowtag)))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 8 index) 4)
+ other-pointer-lowtag)))
(unless (location= value-imag result-imag)
- (inst fst result-imag))
+ (inst fst result-imag))
(inst fxch value-imag))))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-complex-double-float positive-fixnum)
(:results (value :scs (complex-double-reg)))
(:result-types complex-double-float)
(:generator 7
(let ((real-tn (complex-double-reg-real-tn value)))
(with-empty-tn@fp-top (real-tn)
- (inst fldd (make-ea :dword :base object :index index :scale 4
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))))
+ (inst fldd (make-ea :dword :base object :index index :scale 4
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
- (inst fldd (make-ea :dword :base object :index index :scale 4
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- 8)
- other-pointer-lowtag)))))))
+ (inst fldd (make-ea :dword :base object :index index :scale 4
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ 8)
+ other-pointer-lowtag)))))))
(define-vop (data-vector-ref-c/simple-array-complex-double-float)
(:note "inline array access")
(:generator 6
(let ((real-tn (complex-double-reg-real-tn value)))
(with-empty-tn@fp-top (real-tn)
- (inst fldd (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 16 index))
- other-pointer-lowtag)))))
+ (inst fldd (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 16 index))
+ other-pointer-lowtag)))))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
- (inst fldd (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 16 index) 8)
- other-pointer-lowtag)))))))
+ (inst fldd (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 16 index) 8)
+ other-pointer-lowtag)))))))
(define-vop (data-vector-set/simple-array-complex-double-float)
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-double-reg) :target result))
(:arg-types simple-array-complex-double-float positive-fixnum
- complex-double-float)
+ complex-double-float)
(:results (result :scs (complex-double-reg)))
(:result-types complex-double-float)
(:generator 20
(let ((value-real (complex-double-reg-real-tn value))
- (result-real (complex-double-reg-real-tn result)))
+ (result-real (complex-double-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (inst fstd (make-ea :dword :base object :index index :scale 4
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fstd result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (inst fstd (make-ea :dword :base object :index index :scale 4
- :disp (- (* vector-data-offset
- n-word-bytes)
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fstd value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fstd result-real))
- (inst fxch value-real))))))
+ ;; Value is in ST0.
+ (inst fstd (make-ea :dword :base object :index index :scale 4
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fstd result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fstd (make-ea :dword :base object :index index :scale 4
+ :disp (- (* vector-data-offset
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fstd value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fstd result-real))
+ (inst fxch value-real))))))
(let ((value-imag (complex-double-reg-imag-tn value))
- (result-imag (complex-double-reg-imag-tn result)))
+ (result-imag (complex-double-reg-imag-tn result)))
(inst fxch value-imag)
(inst fstd (make-ea :dword :base object :index index :scale 4
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- 8)
- other-pointer-lowtag)))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ 8)
+ other-pointer-lowtag)))
(unless (location= value-imag result-imag)
- (inst fstd result-imag))
+ (inst fstd result-imag))
(inst fxch value-imag))))
(define-vop (data-vector-set-c/simple-array-complex-double-float)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs (complex-double-reg) :target result))
+ (value :scs (complex-double-reg) :target result))
(:info index)
(:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
- complex-double-float)
+ complex-double-float)
(:results (result :scs (complex-double-reg)))
(:result-types complex-double-float)
(:generator 19
(let ((value-real (complex-double-reg-real-tn value))
- (result-real (complex-double-reg-real-tn result)))
+ (result-real (complex-double-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (inst fstd (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 16 index))
- other-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fstd result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (inst fstd (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 16 index))
- other-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fstd value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fstd result-real))
- (inst fxch value-real))))))
+ ;; Value is in ST0.
+ (inst fstd (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 16 index))
+ other-pointer-lowtag)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fstd result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fstd (make-ea :dword :base object
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 16 index))
+ other-pointer-lowtag)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fstd value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fstd result-real))
+ (inst fxch value-real))))))
(let ((value-imag (complex-double-reg-imag-tn value))
- (result-imag (complex-double-reg-imag-tn result)))
+ (result-imag (complex-double-reg-imag-tn result)))
(inst fxch value-imag)
(inst fstd (make-ea :dword :base object
- :disp (- (+ (* vector-data-offset
- n-word-bytes)
- (* 16 index) 8)
- other-pointer-lowtag)))
+ :disp (- (+ (* vector-data-offset
+ n-word-bytes)
+ (* 16 index) 8)
+ other-pointer-lowtag)))
(unless (location= value-imag result-imag)
- (inst fstd result-imag))
+ (inst fstd result-imag))
(inst fxch value-imag))))
(:results (value :scs (unsigned-reg signed-reg)))
(:result-types positive-fixnum)
(:generator 5
- (inst movzx value
- (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (inst movzx value
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
(:translate data-vector-ref)
(:policy :fast-safe)
(:results (value :scs (unsigned-reg signed-reg)))
(:result-types positive-fixnum)
(:generator 4
- (inst movzx value
- (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag)))))
+ (inst movzx value
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target eax))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
(:arg-types ,ptype positive-fixnum positive-fixnum)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 2) :to (:result 0))
- eax)
+ :from (:argument 2) :to (:result 0))
+ eax)
(:results (result :scs (unsigned-reg signed-reg)))
(:result-types positive-fixnum)
(:generator 5
- (move eax value)
- (inst mov (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- al-tn)
- (move result eax)))
+ (move eax value)
+ (inst mov (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ al-tn)
+ (move result eax)))
(define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target eax))
+ (value :scs (unsigned-reg signed-reg) :target eax))
(:info index)
(:arg-types ,ptype (:constant (signed-byte 30))
- positive-fixnum)
+ positive-fixnum)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 1) :to (:result 0))
- eax)
+ :from (:argument 1) :to (:result 0))
+ eax)
(:results (result :scs (unsigned-reg signed-reg)))
(:result-types positive-fixnum)
(:generator 4
- (move eax value)
- (inst mov (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag))
- al-tn)
- (move result eax))))))
+ (move eax value)
+ (inst mov (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag))
+ al-tn)
+ (move result eax))))))
(define-data-vector-frobs simple-array-unsigned-byte-7)
(define-data-vector-frobs simple-array-unsigned-byte-8))
(macrolet ((define-data-vector-frobs (ptype)
`(progn
(define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
- (:arg-types ,ptype positive-fixnum)
- (:results (value :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 5
- (inst movzx value
- (make-ea :word :base object :index index :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,ptype positive-fixnum)
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (inst movzx value
+ (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:info index)
- (:arg-types ,ptype (:constant (signed-byte 30)))
- (:results (value :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 4
- (inst movzx value
- (make-ea :word :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
- other-pointer-lowtag)))))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,ptype (:constant (signed-byte 30)))
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (inst movzx value
+ (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
+ other-pointer-lowtag)))))
(define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target eax))
- (:arg-types ,ptype positive-fixnum positive-fixnum)
- (:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 2) :to (:result 0))
- eax)
- (:results (result :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 5
- (move eax value)
- (inst mov (make-ea :word :base object :index index :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- ax-tn)
- (move result eax)))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
+ (:arg-types ,ptype positive-fixnum positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 2) :to (:result 0))
+ eax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (move eax value)
+ (inst mov (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ ax-tn)
+ (move result eax)))
(define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (unsigned-reg signed-reg) :target eax))
- (:info index)
- (:arg-types ,ptype (:constant (signed-byte 30))
- positive-fixnum)
- (:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 1) :to (:result 0))
- eax)
- (:results (result :scs (unsigned-reg signed-reg)))
- (:result-types positive-fixnum)
- (:generator 4
- (move eax value)
- (inst mov (make-ea :word :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 2 index))
- other-pointer-lowtag))
- ax-tn)
- (move result eax))))))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
+ (:info index)
+ (:arg-types ,ptype (:constant (signed-byte 30))
+ positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 1) :to (:result 0))
+ eax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (move eax value)
+ (inst mov (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 2 index))
+ other-pointer-lowtag))
+ ax-tn)
+ (move result eax))))))
(define-data-vector-frobs simple-array-unsigned-byte-15)
(define-data-vector-frobs simple-array-unsigned-byte-16))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:arg-types simple-base-string positive-fixnum)
(:results (value :scs (character-reg)))
(:result-types character)
(:generator 5
(inst movzx value
- (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-base-string)
(:translate data-vector-ref)
(:result-types character)
(:generator 4
(inst movzx value
- (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-base-string)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (character-reg) :target eax))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (character-reg) :target eax))
(:arg-types simple-base-string positive-fixnum character)
(:temporary (:sc character-reg :offset eax-offset :target result
:from (:argument 2) :to (:result 0))
(:generator 5
(move eax value)
(inst mov (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- al-tn)
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ al-tn)
(move result eax)))
(define-vop (data-vector-set-c/simple-base-string)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (character-reg)))
+ (value :scs (character-reg)))
(:info index)
(:arg-types simple-base-string (:constant (signed-byte 30)) character)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:arg-types simple-base-string positive-fixnum)
(:results (value :scs (character-reg)))
(:result-types character)
(:generator 5
(inst mov value
- (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-base-string)
(:translate data-vector-ref)
(:result-types character)
(:generator 4
(inst mov value
- (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-base-string)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (character-reg) :target result))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (character-reg) :target result))
(:arg-types simple-base-string positive-fixnum character)
(:results (result :scs (character-reg)))
(:result-types character)
(:generator 5
(inst mov (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- value)
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ value)
(move result value)))
(define-vop (data-vector-set-c/simple-base-string)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (character-reg)))
+ (value :scs (character-reg)))
(:info index)
(:arg-types simple-base-string (:constant (signed-byte 30)) character)
(:results (result :scs (character-reg)))
(:result-types character)
(:generator 4
(inst mov (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag))
- value)
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag))
+ value)
(move result value)))
) ; PROGN
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:arg-types simple-array-signed-byte-8 positive-fixnum)
(:results (value :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(inst movsx value
- (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-signed-byte-8)
(:translate data-vector-ref)
(:result-types tagged-num)
(:generator 4
(inst movsx value
- (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag)))))
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-signed-byte-8)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (signed-reg) :target eax))
(:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 2) :to (:result 0))
- eax)
+ :from (:argument 2) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(move eax value)
(inst mov (make-ea :byte :base object :index index :scale 1
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- al-tn)
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ al-tn)
(move result eax)))
(define-vop (data-vector-set-c/simple-array-signed-byte-8)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (value :scs (signed-reg) :target eax))
(:info index)
(:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
- tagged-num)
+ tagged-num)
(:temporary (:sc unsigned-reg :offset eax-offset :target result
- :from (:argument 1) :to (:result 0))
- eax)
+ :from (:argument 1) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 4
(move eax value)
(inst mov (make-ea :byte :base object
- :disp (- (+ (* vector-data-offset n-word-bytes) index)
- other-pointer-lowtag))
- al-tn)
+ :disp (- (+ (* vector-data-offset n-word-bytes) index)
+ other-pointer-lowtag))
+ al-tn)
(move result eax)))
;;; signed-byte-16
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
+ (index :scs (unsigned-reg)))
(:arg-types simple-array-signed-byte-16 positive-fixnum)
(:results (value :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(inst movsx value
- (make-ea :word :base object :index index :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))))
+ (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-signed-byte-16)
(:translate data-vector-ref)
(:result-types tagged-num)
(:generator 4
(inst movsx value
- (make-ea :word :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 2 index))
- other-pointer-lowtag)))))
+ (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 2 index))
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-signed-byte-16)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (signed-reg) :target eax))
(:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
(:temporary (:sc signed-reg :offset eax-offset :target result
- :from (:argument 2) :to (:result 0))
- eax)
+ :from (:argument 2) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 5
(move eax value)
(inst mov (make-ea :word :base object :index index :scale 2
- :disp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- ax-tn)
+ :disp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ ax-tn)
(move result eax)))
(define-vop (data-vector-set-c/simple-array-signed-byte-16)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (value :scs (signed-reg) :target eax))
+ (value :scs (signed-reg) :target eax))
(:info index)
(:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
(:temporary (:sc signed-reg :offset eax-offset :target result
- :from (:argument 1) :to (:result 0))
- eax)
+ :from (:argument 1) :to (:result 0))
+ eax)
(:results (result :scs (signed-reg)))
(:result-types tagged-num)
(:generator 4
(move eax value)
(inst mov
- (make-ea :word :base object
- :disp (- (+ (* vector-data-offset n-word-bytes)
- (* 2 index))
- other-pointer-lowtag))
- ax-tn)
+ (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset n-word-bytes)
+ (* 2 index))
+ other-pointer-lowtag))
+ ax-tn)
(move result eax)))
\f
;;; These VOPs are used for implementing float slots in structures (whose raw
;;;; complex-float raw structure slot accessors
(define-vop (raw-ref-complex-single
- data-vector-ref/simple-array-complex-single-float)
+ data-vector-ref/simple-array-complex-single-float)
(:translate %raw-ref-complex-single)
(:arg-types sb!c::raw-vector positive-fixnum))
(define-vop (raw-ref-complex-single-c
- data-vector-ref-c/simple-array-complex-single-float)
+ data-vector-ref-c/simple-array-complex-single-float)
(:translate %raw-ref-complex-single)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
(define-vop (raw-set-complex-single
- data-vector-set/simple-array-complex-single-float)
+ data-vector-set/simple-array-complex-single-float)
(:translate %raw-set-complex-single)
(:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
(define-vop (raw-set-complex-single-c
- data-vector-set-c/simple-array-complex-single-float)
+ data-vector-set-c/simple-array-complex-single-float)
(:translate %raw-set-complex-single)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30))
- complex-single-float))
+ complex-single-float))
(define-vop (raw-ref-complex-double
- data-vector-ref/simple-array-complex-double-float)
+ data-vector-ref/simple-array-complex-double-float)
(:translate %raw-ref-complex-double)
(:arg-types sb!c::raw-vector positive-fixnum))
(define-vop (raw-ref-complex-double-c
- data-vector-ref-c/simple-array-complex-double-float)
+ data-vector-ref-c/simple-array-complex-double-float)
(:translate %raw-ref-complex-double)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
(define-vop (raw-set-complex-double
- data-vector-set/simple-array-complex-double-float)
+ data-vector-set/simple-array-complex-double-float)
(:translate %raw-set-complex-double)
(:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
(define-vop (raw-set-complex-double-c
- data-vector-set-c/simple-array-complex-double-float)
+ data-vector-set-c/simple-array-complex-double-float)
(:translate %raw-set-complex-double)
(:arg-types sb!c::raw-vector (:constant (signed-byte 30))
- complex-double-float))
+ complex-double-float))
;;; These vops are useful for accessing the bits of a vector
(defun my-make-wired-tn (prim-type-name sc-name offset)
(make-wired-tn (primitive-type-or-lose prim-type-name)
- (sc-number-or-lose sc-name)
- offset))
+ (sc-number-or-lose sc-name)
+ offset))
(defstruct (arg-state (:copier nil))
(stack-frame-size 0))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(multiple-value-bind (ptype stack-sc)
- (if (alien-integer-type-signed type)
- (values 'signed-byte-32 'signed-stack)
- (values 'unsigned-byte-32 'unsigned-stack))
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-32 'signed-stack)
+ (values 'unsigned-byte-32 'unsigned-stack))
(my-make-wired-tn ptype stack-sc stack-frame-size))))
(define-alien-type-method (system-area-pointer :arg-tn) (type state)
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(my-make-wired-tn 'system-area-pointer
- 'sap-stack
- stack-frame-size)))
+ 'sap-stack
+ stack-frame-size)))
#!+long-float
(define-alien-type-method (long-float :arg-tn) (type state)
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(multiple-value-bind (ptype reg-sc)
- (if (alien-integer-type-signed type)
- (values 'signed-byte-32 'signed-reg)
- (values 'unsigned-byte-32 'unsigned-reg))
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-32 'signed-reg)
+ (values 'unsigned-byte-32 'unsigned-reg))
(my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
(define-alien-type-method (system-area-pointer :result-tn) (type state)
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'system-area-pointer 'sap-reg
- (result-reg-offset num-results))))
+ (result-reg-offset num-results))))
#!+long-float
(define-alien-type-method (long-float :result-tn) (type state)
(when (> (length values) 2)
(error "Too many result values from c-call."))
(mapcar (lambda (type)
- (invoke-alien-type-method :result-tn type state))
- values)))
+ (invoke-alien-type-method :result-tn type state))
+ values)))
(!def-vm-support-routine make-call-out-tns (type)
(let ((arg-state (make-arg-state)))
(collect ((arg-tns))
(dolist (arg-type (alien-fun-type-arg-types type))
- (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+ (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset)
- (* (arg-state-stack-frame-size arg-state) n-word-bytes)
- (arg-tns)
- (invoke-alien-type-method :result-tn
- (alien-fun-type-result-type type)
- (make-result-state))))))
+ (* (arg-state-stack-frame-size arg-state) n-word-bytes)
+ (arg-tns)
+ (invoke-alien-type-method :result-tn
+ (alien-fun-type-result-type type)
+ (make-result-state))))))
(deftransform %alien-funcall ((function type &rest args) * * :node node)
(aver (sb!c::constant-lvar-p type))
(let* ((type (sb!c::lvar-value type))
- (env (sb!c::node-lexenv node))
+ (env (sb!c::node-lexenv node))
(arg-types (alien-fun-type-arg-types type))
(result-type (alien-fun-type-result-type type)))
(aver (= (length arg-types) (length args)))
(if (alien-integer-type-signed result-type)
'(values (unsigned 32) (signed 32))
'(values (unsigned 32) (unsigned 32)))
- env))))
+ env))))
`(lambda (function type ,@(lambda-vars))
(declare (ignore type))
(multiple-value-bind (low high)
(define-vop (call-out)
(:args (function :scs (sap-reg))
- (args :more t))
+ (args :more t))
(:results (results :more t))
(:temporary (:sc unsigned-reg :offset eax-offset
- :from :eval :to :result) eax)
+ :from :eval :to :result) eax)
(:temporary (:sc unsigned-reg :offset ecx-offset
- :from :eval :to :result) ecx)
+ :from :eval :to :result) ecx)
(:temporary (:sc unsigned-reg :offset edx-offset
- :from :eval :to :result) edx)
+ :from :eval :to :result) edx)
(:node-var node)
(:vop-var vop)
(:save-p t)
(:ignore args ecx edx)
(:generator 0
(cond ((policy node (> space speed))
- (move eax function)
- (inst call (make-fixup "call_into_c" :foreign)))
- (t
- ;; Setup the NPX for C; all the FP registers need to be
- ;; empty; pop them all.
- (dotimes (i 8)
- (inst fstp fr0-tn))
-
- (inst call function)
- ;; To give the debugger a clue. XX not really internal-error?
- (note-this-location vop :internal-error)
-
- ;; Restore the NPX for lisp; ensure no regs are empty
- (dotimes (i 7)
- (inst fldz))
-
- (if (and results
- (location= (tn-ref-tn results) fr0-tn))
- ;; The return result is in fr0.
- (inst fxch fr7-tn) ; move the result back to fr0
- (inst fldz)) ; insure no regs are empty
- ))))
+ (move eax function)
+ (inst call (make-fixup "call_into_c" :foreign)))
+ (t
+ ;; Setup the NPX for C; all the FP registers need to be
+ ;; empty; pop them all.
+ (dotimes (i 8)
+ (inst fstp fr0-tn))
+
+ (inst call function)
+ ;; To give the debugger a clue. XX not really internal-error?
+ (note-this-location vop :internal-error)
+
+ ;; Restore the NPX for lisp; ensure no regs are empty
+ (dotimes (i 7)
+ (inst fldz))
+
+ (if (and results
+ (location= (tn-ref-tn results) fr0-tn))
+ ;; The return result is in fr0.
+ (inst fxch fr7-tn) ; move the result back to fr0
+ (inst fldz)) ; insure no regs are empty
+ ))))
(define-vop (alloc-number-stack-space)
(:info amount)
(inst wait))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
- (inst sub esp-tn delta)))
+ (inst sub esp-tn delta)))
(move result esp-tn)))
(define-vop (dealloc-number-stack-space)
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
- (inst add esp-tn delta)))
+ (inst add esp-tn delta)))
(when (policy node (= sb!c::float-accuracy 3))
(inst fnstcw (make-ea :word :base esp-tn))
(inst wait)
(aver (not (location= result esp-tn)))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
- (inst mov temp
- (make-ea :dword
- :disp (+ nil-value
- (static-symbol-offset '*alien-stack*)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
- (inst fs-segment-prefix)
- (inst sub (make-ea :dword :scale 1 :index temp) delta)))
+ (inst mov temp
+ (make-ea :dword
+ :disp (+ nil-value
+ (static-symbol-offset '*alien-stack*)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
+ (inst fs-segment-prefix)
+ (inst sub (make-ea :dword :scale 1 :index temp) delta)))
(load-tl-symbol-value result *alien-stack*))
#!-sb-thread
(:generator 0
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
- (inst mov temp
- (make-ea :dword
- :disp (+ nil-value
- (static-symbol-offset '*alien-stack*)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
- (inst fs-segment-prefix)
- (inst add (make-ea :dword :scale 1 :index temp) delta))))
+ (inst mov temp
+ (make-ea :dword
+ :disp (+ nil-value
+ (static-symbol-offset '*alien-stack*)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
+ (inst fs-segment-prefix)
+ (inst add (make-ea :dword :scale 1 :index temp) delta))))
#!-sb-thread
(:generator 0
(unless (zerop amount)
pointer to the arguments."
(declare (ignore arg-types))
(let* ((segment (make-segment))
- (eax eax-tn)
- (edx edx-tn)
- (ebp ebp-tn)
- (esp esp-tn)
- ([ebp-8] (make-ea :dword :base ebp :disp -8))
- ([ebp-4] (make-ea :dword :base ebp :disp -4)))
+ (eax eax-tn)
+ (edx edx-tn)
+ (ebp ebp-tn)
+ (esp esp-tn)
+ ([ebp-8] (make-ea :dword :base ebp :disp -8))
+ ([ebp-4] (make-ea :dword :base ebp :disp -4)))
(assemble (segment)
- (inst push ebp) ; save old frame pointer
- (inst mov ebp esp) ; establish new frame
- (inst mov eax esp) ;
- (inst sub eax 8) ; place for result
- (inst push eax) ; arg2
- (inst add eax 16) ; arguments
- (inst push eax) ; arg1
- (inst push (ash index 2)) ; arg0
- (inst push (get-lisp-obj-address #'enter-alien-callback)) ; function
- (inst mov eax (foreign-symbol-address "funcall3"))
- (inst call eax)
- ;; now put the result into the right register
- (cond
- ((and (alien-integer-type-p return-type)
- (eql (alien-type-bits return-type) 64))
- (inst mov eax [ebp-8])
- (inst mov edx [ebp-4]))
- ((or (alien-integer-type-p return-type)
- (alien-pointer-type-p return-type)
- (alien-type-= #.(parse-alien-type 'system-area-pointer nil)
- return-type))
- (inst mov eax [ebp-8]))
- ((alien-single-float-type-p return-type)
- (inst fld [ebp-8]))
- ((alien-double-float-type-p return-type)
- (inst fldd [ebp-8]))
- ((alien-void-type-p return-type))
- (t
- (error "unrecognized alien type: ~A" return-type)))
- (inst mov esp ebp) ; discard frame
- (inst pop ebp) ; restore frame pointer
- (inst ret))
+ (inst push ebp) ; save old frame pointer
+ (inst mov ebp esp) ; establish new frame
+ (inst mov eax esp) ;
+ (inst sub eax 8) ; place for result
+ (inst push eax) ; arg2
+ (inst add eax 16) ; arguments
+ (inst push eax) ; arg1
+ (inst push (ash index 2)) ; arg0
+ (inst push (get-lisp-obj-address #'enter-alien-callback)) ; function
+ (inst mov eax (foreign-symbol-address "funcall3"))
+ (inst call eax)
+ ;; now put the result into the right register
+ (cond
+ ((and (alien-integer-type-p return-type)
+ (eql (alien-type-bits return-type) 64))
+ (inst mov eax [ebp-8])
+ (inst mov edx [ebp-4]))
+ ((or (alien-integer-type-p return-type)
+ (alien-pointer-type-p return-type)
+ (alien-type-= #.(parse-alien-type 'system-area-pointer nil)
+ return-type))
+ (inst mov eax [ebp-8]))
+ ((alien-single-float-type-p return-type)
+ (inst fld [ebp-8]))
+ ((alien-double-float-type-p return-type)
+ (inst fldd [ebp-8]))
+ ((alien-void-type-p return-type))
+ (t
+ (error "unrecognized alien type: ~A" return-type)))
+ (inst mov esp ebp) ; discard frame
+ (inst pop ebp) ; restore frame pointer
+ (inst ret))
(finalize-segment segment)
;; Now that the segment is done, convert it to a static
;; vector we can point foreign code to.
(let ((buffer (sb!assem::segment-buffer segment)))
(make-static-vector (length buffer)
- :element-type '(unsigned-byte 8)
- :initial-contents buffer))))
+ :element-type '(unsigned-byte 8)
+ :initial-contents buffer))))
(declare (type unsigned-byte n))
(if (< n register-arg-count)
(make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number
- (nth n *register-arg-offsets*))
+ (nth n *register-arg-offsets*))
(make-wired-tn *backend-t-primitive-type* control-stack-sc-number n)))
;;; Make a passing location TN for a local call return PC.
(!def-vm-support-routine make-return-pc-passing-location (standard)
(declare (ignore standard))
(make-wired-tn (primitive-type-or-lose 'system-area-pointer)
- sap-stack-sc-number return-pc-save-offset))
+ sap-stack-sc-number return-pc-save-offset))
;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a
;;; location to pass OLD-FP in.
(!def-vm-support-routine make-old-fp-passing-location (standard)
(declare (ignore standard))
(make-wired-tn *fixnum-primitive-type* control-stack-sc-number
- ocfp-save-offset))
+ ocfp-save-offset))
;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current
;;; function. We treat these specially so that the debugger can find
;;; them at a known location.
;;;
;;; Without using a save-tn - which does not make much sense if it is
-;;; wired to the stack?
+;;; wired to the stack?
(!def-vm-support-routine make-old-fp-save-location (physenv)
(physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type*
- control-stack-sc-number
- ocfp-save-offset)
- physenv))
+ control-stack-sc-number
+ ocfp-save-offset)
+ physenv))
(!def-vm-support-routine make-return-pc-save-location (physenv)
(physenv-debug-live-tn
(make-wired-tn (primitive-type-or-lose 'system-area-pointer)
- sap-stack-sc-number return-pc-save-offset)
+ sap-stack-sc-number return-pc-save-offset)
physenv))
;;; Make a TN for the standard argument count passing location. We only
;;; continuation within a function.
(!def-vm-support-routine make-unknown-values-locations ()
(list (make-stack-pointer-tn)
- (make-normal-tn *fixnum-primitive-type*)))
+ (make-normal-tn *fixnum-primitive-type*)))
;;; This function is called by the ENTRY-ANALYZE phase, allowing
;;; VM-dependent initialization of the IR2-COMPONENT structure. We
;; we'll just live with this ugliness. -- WHN 2002-01-02
(dotimes (i (1+ code-constants-offset))
(vector-push-extend nil
- (ir2-component-constants (component-info component))))
+ (ir2-component-constants (component-info component))))
(values))
\f
;;;; frame hackery
(unless copy-more-arg-follows
;; The args fit within the frame so just allocate the frame.
(inst lea esp-tn
- (make-ea :dword :base ebp-tn
- :disp (- (* n-word-bytes
- (max 3 (sb-allocated-size 'stack)))))))
+ (make-ea :dword :base ebp-tn
+ :disp (- (* n-word-bytes
+ (max 3 (sb-allocated-size 'stack)))))))
(trace-table-entry trace-table-normal)))
;;; callee (who has the same size stack as us).
(define-vop (allocate-frame)
(:results (res :scs (any-reg control-stack))
- (nfp))
+ (nfp))
(:info callee)
(:ignore nfp callee)
(:generator 2
;;; returned, regardless of the number of values desired.
(defun default-unknown-values (vop values nvals)
(declare (type (or tn-ref null) values)
- (type unsigned-byte nvals))
+ (type unsigned-byte nvals))
(cond
((<= nvals 1)
(note-this-location vop :single-value-return)
(inst jmp-short regs-defaulted)
;; Default the unsuppled registers.
(let* ((2nd-tn-ref (tn-ref-across values))
- (2nd-tn (tn-ref-tn 2nd-tn-ref)))
- (inst mov 2nd-tn nil-value)
- (when (> nvals 2)
- (loop
- for tn-ref = (tn-ref-across 2nd-tn-ref)
- then (tn-ref-across tn-ref)
- for count from 2 below register-arg-count
- do (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
+ (2nd-tn (tn-ref-tn 2nd-tn-ref)))
+ (inst mov 2nd-tn nil-value)
+ (when (> nvals 2)
+ (loop
+ for tn-ref = (tn-ref-across 2nd-tn-ref)
+ then (tn-ref-across tn-ref)
+ for count from 2 below register-arg-count
+ do (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
(inst mov ebx-tn esp-tn)
(emit-label regs-defaulted)
(inst mov esp-tn ebx-tn)))
;; NVALS=6 that is 73/89 bytes, and for NVALS=7 that is 87/107
;; bytes which is likely better than using the blt below.
(let ((regs-defaulted (gen-label))
- (defaulting-done (gen-label))
- (default-stack-slots (gen-label)))
+ (defaulting-done (gen-label))
+ (default-stack-slots (gen-label)))
(note-this-location vop :unknown-return)
;; Branch off to the MV case.
(inst jmp-short regs-defaulted)
;; Default the register args
(inst mov eax-tn nil-value)
(do ((i 1 (1+ i))
- (val (tn-ref-across values) (tn-ref-across val)))
- ((= i (min nvals register-arg-count)))
- (inst mov (tn-ref-tn val) eax-tn))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i (min nvals register-arg-count)))
+ (inst mov (tn-ref-tn val) eax-tn))
;; Fake other registers so it looks like we returned with all the
;; registers filled in.
(inst mov eax-tn nil-value)
(storew edx-tn ebx-tn -1)
(collect ((defaults))
- (do ((i register-arg-count (1+ i))
- (val (do ((i 0 (1+ i))
- (val values (tn-ref-across val)))
- ((= i register-arg-count) val))
- (tn-ref-across val)))
- ((null val))
- (let ((default-lab (gen-label))
- (tn (tn-ref-tn val)))
- (defaults (cons default-lab tn))
-
- (inst cmp ecx-tn (fixnumize i))
- (inst jmp :be default-lab)
- (loadw edx-tn ebx-tn (- (1+ i)))
- (inst mov tn edx-tn)))
-
- (emit-label defaulting-done)
- (loadw edx-tn ebx-tn -1)
- (move esp-tn ebx-tn)
-
- (let ((defaults (defaults)))
- (when defaults
- (assemble (*elsewhere*)
- (trace-table-entry trace-table-fun-prologue)
- (emit-label default-stack-slots)
- (dolist (default defaults)
- (emit-label (car default))
- (inst mov (cdr default) eax-tn))
- (inst jmp defaulting-done)
- (trace-table-entry trace-table-normal)))))))
+ (do ((i register-arg-count (1+ i))
+ (val (do ((i 0 (1+ i))
+ (val values (tn-ref-across val)))
+ ((= i register-arg-count) val))
+ (tn-ref-across val)))
+ ((null val))
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn val)))
+ (defaults (cons default-lab tn))
+
+ (inst cmp ecx-tn (fixnumize i))
+ (inst jmp :be default-lab)
+ (loadw edx-tn ebx-tn (- (1+ i)))
+ (inst mov tn edx-tn)))
+
+ (emit-label defaulting-done)
+ (loadw edx-tn ebx-tn -1)
+ (move esp-tn ebx-tn)
+
+ (let ((defaults (defaults)))
+ (when defaults
+ (assemble (*elsewhere*)
+ (trace-table-entry trace-table-fun-prologue)
+ (emit-label default-stack-slots)
+ (dolist (default defaults)
+ (emit-label (car default))
+ (inst mov (cdr default) eax-tn))
+ (inst jmp defaulting-done)
+ (trace-table-entry trace-table-normal)))))))
(t
;; 91 bytes for this branch.
(let ((regs-defaulted (gen-label))
- (restore-edi (gen-label))
- (no-stack-args (gen-label))
- (default-stack-vals (gen-label))
- (count-okay (gen-label)))
+ (restore-edi (gen-label))
+ (no-stack-args (gen-label))
+ (default-stack-vals (gen-label))
+ (count-okay (gen-label)))
(note-this-location vop :unknown-return)
;; Branch off to the MV case.
(inst jmp-short regs-defaulted)
;; Compute a pointer to where to put the [defaulted] stack values.
(emit-label no-stack-args)
(inst lea edi-tn
- (make-ea :dword :base ebp-tn
- :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+ (make-ea :dword :base ebp-tn
+ :disp (* (- (1+ register-arg-count)) n-word-bytes)))
;; Load EAX with NIL so we can quickly store it, and set up
;; stuff for the loop.
(inst mov eax-tn nil-value)
(inst mov eax-tn ecx-tn)
;; Compute a pointer to where the stack args go.
(inst lea edi-tn
- (make-ea :dword :base ebp-tn
- :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+ (make-ea :dword :base ebp-tn
+ :disp (* (- (1+ register-arg-count)) n-word-bytes)))
;; Save ESI, and compute a pointer to where the args come from.
(storew esi-tn ebx-tn (- (1+ 2)))
(inst lea esi-tn
- (make-ea :dword :base ebx-tn
- :disp (* (- (1+ register-arg-count)) n-word-bytes)))
+ (make-ea :dword :base ebx-tn
+ :disp (* (- (1+ register-arg-count)) n-word-bytes)))
;; Do the copy.
- (inst shr ecx-tn word-shift) ; make word count
+ (inst shr ecx-tn word-shift) ; make word count
(inst std)
(inst rep)
(inst movs :dword)
;; If none, then just blow out of here.
(inst jmp :le restore-edi)
(inst mov ecx-tn eax-tn)
- (inst shr ecx-tn word-shift) ; word count
+ (inst shr ecx-tn word-shift) ; word count
;; Load EAX with NIL for fast storing.
(inst mov eax-tn nil-value)
;; Do the store.
(defun receive-unknown-values (args nargs start count)
(declare (type tn args nargs start count))
(let ((variable-values (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst jmp-short variable-values)
(cond ((location= start (first *register-arg-tns*))
;;; handles is allocation of the result temporaries.
(define-vop (unknown-values-receiver)
(:temporary (:sc descriptor-reg :offset ebx-offset
- :from :eval :to (:result 0))
- values-start)
+ :from :eval :to (:result 0))
+ values-start)
(:temporary (:sc any-reg :offset ecx-offset
- :from :eval :to (:result 1))
- nvals)
+ :from :eval :to (:result 1))
+ nvals)
(:results (start :scs (any-reg control-stack))
- (count :scs (any-reg control-stack))))
+ (count :scs (any-reg control-stack))))
\f
;;;; local call with unknown values convention return
;;; function.
(define-vop (call-local)
(:args (fp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:results (values :more t))
(:save-p t)
(:move-args :local-call)
(let ((ret-tn (callee-return-pc-tn callee)))
#+nil
(format t "*call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
- ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
- (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
+ ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
+ (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
;; Is the return-pc on the stack or in a register?
(sc-case ret-tn
- ((sap-stack)
- #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
- (tn-offset ret-tn))
- (storew (make-fixup nil :code-object return)
- ebp-tn (- (1+ (tn-offset ret-tn)))))
- ((sap-reg)
- (inst lea ret-tn (make-fixup nil :code-object return)))))
+ ((sap-stack)
+ #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
+ (tn-offset ret-tn))
+ (storew (make-fixup nil :code-object return)
+ ebp-tn (- (1+ (tn-offset ret-tn)))))
+ ((sap-reg)
+ (inst lea ret-tn (make-fixup nil :code-object return)))))
(note-this-location vop :call-site)
(inst jmp target)
;;; glob and the number of values received.
(define-vop (multiple-call-local unknown-values-receiver)
(:args (fp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:save-p t)
(:move-args :local-call)
(:info save callee target)
(let ((ret-tn (callee-return-pc-tn callee)))
#+nil
(format t "*multiple-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
- ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
- (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
+ ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
+ (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
;; Is the return-pc on the stack or in a register?
(sc-case ret-tn
- ((sap-stack)
- #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
- (tn-offset ret-tn))
- ;; Stack
- (storew (make-fixup nil :code-object return)
- ebp-tn (- (1+ (tn-offset ret-tn)))))
- ((sap-reg)
- ;; Register
- (inst lea ret-tn (make-fixup nil :code-object return)))))
+ ((sap-stack)
+ #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
+ (tn-offset ret-tn))
+ ;; Stack
+ (storew (make-fixup nil :code-object return)
+ ebp-tn (- (1+ (tn-offset ret-tn)))))
+ ((sap-reg)
+ ;; Register
+ (inst lea ret-tn (make-fixup nil :code-object return)))))
(note-this-location vop :call-site)
(inst jmp target)
;;; we use MAYBE-LOAD-STACK-TN.
(define-vop (known-call-local)
(:args (fp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:results (res :more t))
(:move-args :local-call)
(:save-p t)
#+nil
(format t "*known-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
- ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
- (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
+ ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
+ (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
;; Is the return-pc on the stack or in a register?
(sc-case ret-tn
- ((sap-stack)
- #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
- (tn-offset ret-tn))
- ;; Stack
- (storew (make-fixup nil :code-object return)
- ebp-tn (- (1+ (tn-offset ret-tn)))))
- ((sap-reg)
- ;; Register
- (inst lea ret-tn (make-fixup nil :code-object return)))))
+ ((sap-stack)
+ #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
+ (tn-offset ret-tn))
+ ;; Stack
+ (storew (make-fixup nil :code-object return)
+ ebp-tn (- (1+ (tn-offset ret-tn)))))
+ ((sap-reg)
+ ;; Register
+ (inst lea ret-tn (make-fixup nil :code-object return)))))
(note-this-location vop :call-site)
(inst jmp target)
#+nil
(define-vop (known-return)
(:args (old-fp)
- (return-pc :scs (any-reg immediate-stack) :target rpc)
- (vals :more t))
+ (return-pc :scs (any-reg immediate-stack) :target rpc)
+ (vals :more t))
(:move-args :known-return)
(:info val-locs)
(:temporary (:sc unsigned-reg :from (:argument 1)) rpc)
;;; The return-pc may be in a register or on the stack in any slot.
(define-vop (known-return)
(:args (old-fp)
- (return-pc)
- (vals :more t))
+ (return-pc)
+ (vals :more t))
(:move-args :known-return)
(:info val-locs)
(:ignore val-locs vals)
(trace-table-entry trace-table-fun-epilogue)
#+nil (format t "*known-return: old-fp ~S, tn-kind ~S; ~S ~S~%"
- old-fp (sb!c::tn-kind old-fp) (sb!c::tn-save-tn old-fp)
- (sb!c::tn-kind (sb!c::tn-save-tn old-fp)))
+ old-fp (sb!c::tn-kind old-fp) (sb!c::tn-save-tn old-fp)
+ (sb!c::tn-kind (sb!c::tn-save-tn old-fp)))
#+nil (format t "*known-return: return-pc ~S, tn-kind ~S; ~S ~S~%"
- return-pc (sb!c::tn-kind return-pc)
- (sb!c::tn-save-tn return-pc)
- (sb!c::tn-kind (sb!c::tn-save-tn return-pc)))
+ return-pc (sb!c::tn-kind return-pc)
+ (sb!c::tn-save-tn return-pc)
+ (sb!c::tn-kind (sb!c::tn-save-tn return-pc)))
;; return-pc may be either in a register or on the stack.
(sc-case return-pc
((sap-reg)
(sc-case old-fp
- ((control-stack)
-
- #+nil (format t "*known-return: old-fp ~S on stack; offset=~S~%"
- old-fp (tn-offset old-fp))
-
- (cond ((zerop (tn-offset old-fp))
- ;; Zot all of the stack except for the old-fp.
- (inst lea esp-tn (make-ea :dword :base ebp-tn
- :disp (- (* (1+ ocfp-save-offset)
- n-word-bytes))))
- ;; Restore the old fp from its save location on the stack,
- ;; and zot the stack.
- (inst pop ebp-tn))
-
- (t
- (cerror "Continue anyway"
- "VOP return-local doesn't work if old-fp (in slot ~
+ ((control-stack)
+
+ #+nil (format t "*known-return: old-fp ~S on stack; offset=~S~%"
+ old-fp (tn-offset old-fp))
+
+ (cond ((zerop (tn-offset old-fp))
+ ;; Zot all of the stack except for the old-fp.
+ (inst lea esp-tn (make-ea :dword :base ebp-tn
+ :disp (- (* (1+ ocfp-save-offset)
+ n-word-bytes))))
+ ;; Restore the old fp from its save location on the stack,
+ ;; and zot the stack.
+ (inst pop ebp-tn))
+
+ (t
+ (cerror "Continue anyway"
+ "VOP return-local doesn't work if old-fp (in slot ~
~S) is not in slot 0"
- (tn-offset old-fp)))))
+ (tn-offset old-fp)))))
- ((any-reg descriptor-reg)
- ;; Zot all the stack.
- (move esp-tn ebp-tn)
- ;; Restore the old-fp.
- (move ebp-tn old-fp)))
+ ((any-reg descriptor-reg)
+ ;; Zot all the stack.
+ (move esp-tn ebp-tn)
+ ;; Restore the old-fp.
+ (move ebp-tn old-fp)))
;; Return; return-pc is in a register.
(inst jmp return-pc))
((sap-stack)
#+nil (format t "*known-return: return-pc ~S on stack; offset=~S~%"
- return-pc (tn-offset return-pc))
+ return-pc (tn-offset return-pc))
;; Zot all of the stack except for the old-fp and return-pc.
(inst lea esp-tn
- (make-ea :dword :base ebp-tn
- :disp (- (* (1+ (tn-offset return-pc)) n-word-bytes))))
+ (make-ea :dword :base ebp-tn
+ :disp (- (* (1+ (tn-offset return-pc)) n-word-bytes))))
;; Restore the old fp. old-fp may be either on the stack in its
;; save location or in a register, in either case this restores it.
(move ebp-tn old-fp)
;;; passed as a more arg, but there is no new-FP, since the arguments
;;; have been set up in the current frame.
(macrolet ((define-full-call (name named return variable)
- (aver (not (and variable (eq return :tail))))
- `(define-vop (,name
- ,@(when (eq return :unknown)
- '(unknown-values-receiver)))
- (:args
- ,@(unless (eq return :tail)
- '((new-fp :scs (any-reg) :to (:argument 1))))
-
- (fun :scs (descriptor-reg control-stack)
- :target eax :to (:argument 0))
-
- ,@(when (eq return :tail)
- '((old-fp)
- (return-pc)))
-
- ,@(unless variable '((args :more t :scs (descriptor-reg)))))
-
- ,@(when (eq return :fixed)
- '((:results (values :more t))))
-
- (:save-p ,(if (eq return :tail) :compute-only t))
-
- ,@(unless (or (eq return :tail) variable)
- '((:move-args :full-call)))
-
- (:vop-var vop)
- (:info
- ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
-
- (:ignore
- ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(args)))
-
- ;; We pass either the fdefn object (for named call) or
- ;; the actual function object (for unnamed call) in
- ;; EAX. With named call, closure-tramp will replace it
- ;; with the real function and invoke the real function
- ;; for closures. Non-closures do not need this value,
- ;; so don't care what shows up in it.
- (:temporary
- (:sc descriptor-reg
- :offset eax-offset
- :from (:argument 0)
- :to :eval)
- eax)
-
- ;; We pass the number of arguments in ECX.
- (:temporary (:sc unsigned-reg :offset ecx-offset :to :eval) ecx)
-
- ;; With variable call, we have to load the
- ;; register-args out of the (new) stack frame before
- ;; doing the call. Therefore, we have to tell the
- ;; lifetime stuff that we need to use them.
- ,@(when variable
- (mapcar (lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :from (:argument 0)
- :to :eval)
- ,name))
- *register-arg-names* *register-arg-offsets*))
-
- ,@(when (eq return :tail)
- '((:temporary (:sc unsigned-reg
- :from (:argument 1)
- :to (:argument 2))
- old-fp-tmp)))
-
- (:generator ,(+ (if named 5 0)
- (if variable 19 1)
- (if (eq return :tail) 0 10)
- 15
- (if (eq return :unknown) 25 0))
- (trace-table-entry trace-table-call-site)
-
- ;; This has to be done before the frame pointer is
- ;; changed! EAX stores the 'lexical environment' needed
- ;; for closures.
- (move eax fun)
-
-
- ,@(if variable
- ;; For variable call, compute the number of
- ;; arguments and move some of the arguments to
- ;; registers.
- (collect ((noise))
- ;; Compute the number of arguments.
- (noise '(inst mov ecx new-fp))
- (noise '(inst sub ecx esp-tn))
- ;; Move the necessary args to registers,
- ;; this moves them all even if they are
- ;; not all needed.
- (loop
- for name in *register-arg-names*
- for index downfrom -1
- do (noise `(loadw ,name new-fp ,index)))
- (noise))
- '((if (zerop nargs)
- (inst xor ecx ecx)
- (inst mov ecx (fixnumize nargs)))))
- ,@(cond ((eq return :tail)
- '(;; Python has figured out what frame we should
- ;; return to so might as well use that clue.
- ;; This seems really important to the
- ;; implementation of things like
- ;; (without-interrupts ...)
- ;;
- ;; dtc; Could be doing a tail call from a
- ;; known-local-call etc in which the old-fp
- ;; or ret-pc are in regs or in non-standard
- ;; places. If the passing location were
- ;; wired to the stack in standard locations
- ;; then these moves will be un-necessary;
- ;; this is probably best for the x86.
- (sc-case old-fp
- ((control-stack)
- (unless (= ocfp-save-offset
- (tn-offset old-fp))
- ;; FIXME: FORMAT T for stale
- ;; diagnostic output (several of
- ;; them around here), ick
- (format t "** tail-call old-fp not S0~%")
- (move old-fp-tmp old-fp)
- (storew old-fp-tmp
- ebp-tn
- (- (1+ ocfp-save-offset)))))
- ((any-reg descriptor-reg)
- (format t "** tail-call old-fp in reg not S0~%")
- (storew old-fp
- ebp-tn
- (- (1+ ocfp-save-offset)))))
-
- ;; For tail call, we have to push the
- ;; return-pc so that it looks like we CALLed
- ;; despite the fact that we are going to JMP.
- (inst push return-pc)
- ))
- (t
- ;; For non-tail call, we have to save our
- ;; frame pointer and install the new frame
- ;; pointer. We can't load stack tns after this
- ;; point.
- `(;; Python doesn't seem to allocate a frame
- ;; here which doesn't leave room for the
- ;; ofp/ret stuff.
-
- ;; The variable args are on the stack and
- ;; become the frame, but there may be <3
- ;; args and 3 stack slots are assumed
- ;; allocate on the call. So need to ensure
- ;; there are at least 3 slots. This hack
- ;; just adds 3 more.
- ,(if variable
- '(inst sub esp-tn (fixnumize 3)))
-
- ;; Save the fp
- (storew ebp-tn new-fp (- (1+ ocfp-save-offset)))
-
- (move ebp-tn new-fp) ; NB - now on new stack frame.
- )))
-
- (note-this-location vop :call-site)
-
- (inst ,(if (eq return :tail) 'jmp 'call)
- (make-ea :dword :base eax
- :disp ,(if named
- '(- (* fdefn-raw-addr-slot
- n-word-bytes)
- other-pointer-lowtag)
- '(- (* closure-fun-slot n-word-bytes)
- fun-pointer-lowtag))))
- ,@(ecase return
- (:fixed
- '((default-unknown-values vop values nvals)))
- (:unknown
- '((note-this-location vop :unknown-return)
- (receive-unknown-values values-start nvals start count)))
- (:tail))
- (trace-table-entry trace-table-normal)))))
+ (aver (not (and variable (eq return :tail))))
+ `(define-vop (,name
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
+ (:args
+ ,@(unless (eq return :tail)
+ '((new-fp :scs (any-reg) :to (:argument 1))))
+
+ (fun :scs (descriptor-reg control-stack)
+ :target eax :to (:argument 0))
+
+ ,@(when (eq return :tail)
+ '((old-fp)
+ (return-pc)))
+
+ ,@(unless variable '((args :more t :scs (descriptor-reg)))))
+
+ ,@(when (eq return :fixed)
+ '((:results (values :more t))))
+
+ (:save-p ,(if (eq return :tail) :compute-only t))
+
+ ,@(unless (or (eq return :tail) variable)
+ '((:move-args :full-call)))
+
+ (:vop-var vop)
+ (:info
+ ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(nargs))
+ ,@(when (eq return :fixed) '(nvals)))
+
+ (:ignore
+ ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(args)))
+
+ ;; We pass either the fdefn object (for named call) or
+ ;; the actual function object (for unnamed call) in
+ ;; EAX. With named call, closure-tramp will replace it
+ ;; with the real function and invoke the real function
+ ;; for closures. Non-closures do not need this value,
+ ;; so don't care what shows up in it.
+ (:temporary
+ (:sc descriptor-reg
+ :offset eax-offset
+ :from (:argument 0)
+ :to :eval)
+ eax)
+
+ ;; We pass the number of arguments in ECX.
+ (:temporary (:sc unsigned-reg :offset ecx-offset :to :eval) ecx)
+
+ ;; With variable call, we have to load the
+ ;; register-args out of the (new) stack frame before
+ ;; doing the call. Therefore, we have to tell the
+ ;; lifetime stuff that we need to use them.
+ ,@(when variable
+ (mapcar (lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :from (:argument 0)
+ :to :eval)
+ ,name))
+ *register-arg-names* *register-arg-offsets*))
+
+ ,@(when (eq return :tail)
+ '((:temporary (:sc unsigned-reg
+ :from (:argument 1)
+ :to (:argument 2))
+ old-fp-tmp)))
+
+ (:generator ,(+ (if named 5 0)
+ (if variable 19 1)
+ (if (eq return :tail) 0 10)
+ 15
+ (if (eq return :unknown) 25 0))
+ (trace-table-entry trace-table-call-site)
+
+ ;; This has to be done before the frame pointer is
+ ;; changed! EAX stores the 'lexical environment' needed
+ ;; for closures.
+ (move eax fun)
+
+
+ ,@(if variable
+ ;; For variable call, compute the number of
+ ;; arguments and move some of the arguments to
+ ;; registers.
+ (collect ((noise))
+ ;; Compute the number of arguments.
+ (noise '(inst mov ecx new-fp))
+ (noise '(inst sub ecx esp-tn))
+ ;; Move the necessary args to registers,
+ ;; this moves them all even if they are
+ ;; not all needed.
+ (loop
+ for name in *register-arg-names*
+ for index downfrom -1
+ do (noise `(loadw ,name new-fp ,index)))
+ (noise))
+ '((if (zerop nargs)
+ (inst xor ecx ecx)
+ (inst mov ecx (fixnumize nargs)))))
+ ,@(cond ((eq return :tail)
+ '(;; Python has figured out what frame we should
+ ;; return to so might as well use that clue.
+ ;; This seems really important to the
+ ;; implementation of things like
+ ;; (without-interrupts ...)
+ ;;
+ ;; dtc; Could be doing a tail call from a
+ ;; known-local-call etc in which the old-fp
+ ;; or ret-pc are in regs or in non-standard
+ ;; places. If the passing location were
+ ;; wired to the stack in standard locations
+ ;; then these moves will be un-necessary;
+ ;; this is probably best for the x86.
+ (sc-case old-fp
+ ((control-stack)
+ (unless (= ocfp-save-offset
+ (tn-offset old-fp))
+ ;; FIXME: FORMAT T for stale
+ ;; diagnostic output (several of
+ ;; them around here), ick
+ (format t "** tail-call old-fp not S0~%")
+ (move old-fp-tmp old-fp)
+ (storew old-fp-tmp
+ ebp-tn
+ (- (1+ ocfp-save-offset)))))
+ ((any-reg descriptor-reg)
+ (format t "** tail-call old-fp in reg not S0~%")
+ (storew old-fp
+ ebp-tn
+ (- (1+ ocfp-save-offset)))))
+
+ ;; For tail call, we have to push the
+ ;; return-pc so that it looks like we CALLed
+ ;; despite the fact that we are going to JMP.
+ (inst push return-pc)
+ ))
+ (t
+ ;; For non-tail call, we have to save our
+ ;; frame pointer and install the new frame
+ ;; pointer. We can't load stack tns after this
+ ;; point.
+ `(;; Python doesn't seem to allocate a frame
+ ;; here which doesn't leave room for the
+ ;; ofp/ret stuff.
+
+ ;; The variable args are on the stack and
+ ;; become the frame, but there may be <3
+ ;; args and 3 stack slots are assumed
+ ;; allocate on the call. So need to ensure
+ ;; there are at least 3 slots. This hack
+ ;; just adds 3 more.
+ ,(if variable
+ '(inst sub esp-tn (fixnumize 3)))
+
+ ;; Save the fp
+ (storew ebp-tn new-fp (- (1+ ocfp-save-offset)))
+
+ (move ebp-tn new-fp) ; NB - now on new stack frame.
+ )))
+
+ (note-this-location vop :call-site)
+
+ (inst ,(if (eq return :tail) 'jmp 'call)
+ (make-ea :dword :base eax
+ :disp ,(if named
+ '(- (* fdefn-raw-addr-slot
+ n-word-bytes)
+ other-pointer-lowtag)
+ '(- (* closure-fun-slot n-word-bytes)
+ fun-pointer-lowtag))))
+ ,@(ecase return
+ (:fixed
+ '((default-unknown-values vop values nvals)))
+ (:unknown
+ '((note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count)))
+ (:tail))
+ (trace-table-entry trace-table-normal)))))
(define-full-call call nil :fixed nil)
(define-full-call call-named t :fixed nil)
;;; routine. We just set things up so that it can find what it needs.
(define-vop (tail-call-variable)
(:args (args :scs (any-reg control-stack) :target esi)
- (function :scs (descriptor-reg control-stack) :target eax)
- (old-fp)
- (ret-addr))
+ (function :scs (descriptor-reg control-stack) :target eax)
+ (old-fp)
+ (ret-addr))
(:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) esi)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)) eax)
; (:ignore ret-addr old-fp)
;; The following assumes that the return-pc and old-fp are on the
;; stack in their standard save locations - Check this.
(unless (and (sc-is old-fp control-stack)
- (= (tn-offset old-fp) ocfp-save-offset))
- (error "tail-call-variable: ocfp not on stack in standard save location?"))
+ (= (tn-offset old-fp) ocfp-save-offset))
+ (error "tail-call-variable: ocfp not on stack in standard save location?"))
(unless (and (sc-is ret-addr sap-stack)
- (= (tn-offset ret-addr) return-pc-save-offset))
- (error "tail-call-variable: ret-addr not on stack in standard save location?"))
+ (= (tn-offset ret-addr) return-pc-save-offset))
+ (error "tail-call-variable: ret-addr not on stack in standard save location?"))
;; And jump to the assembly routine.
;;; having problems targeting args to regs -- using temps instead.
(define-vop (return-single)
(:args (old-fp)
- (return-pc)
- (value))
+ (return-pc)
+ (value))
(:temporary (:sc unsigned-reg) ofp)
(:temporary (:sc unsigned-reg) ret)
(:ignore value)
;;; the values, and jump directly to return-pc.
(define-vop (return)
(:args (old-fp)
- (return-pc :to (:eval 1))
- (values :more t))
+ (return-pc :to (:eval 1))
+ (values :more t))
(:ignore values)
(:info nvals)
;; registers so that we can default the argument registers without
;; trashing return-pc.
(:temporary (:sc unsigned-reg :offset (first *register-arg-offsets*)
- :from :eval) a0)
+ :from :eval) a0)
(:temporary (:sc unsigned-reg :offset (second *register-arg-offsets*)
- :from :eval) a1)
+ :from :eval) a1)
(:temporary (:sc unsigned-reg :offset (third *register-arg-offsets*)
- :from :eval) a2)
+ :from :eval) a2)
(:generator 6
(trace-table-entry trace-table-fun-epilogue)
;; Establish the values pointer and values count.
(move ebx ebp-tn)
(if (zerop nvals)
- (inst xor ecx ecx) ; smaller
+ (inst xor ecx ecx) ; smaller
(inst mov ecx (fixnumize nvals)))
;; Restore the frame pointer.
(move ebp-tn old-fp)
;; Clear as much of the stack as possible, but not past the return
;; address.
(inst lea esp-tn (make-ea :dword :base ebx
- :disp (- (* (max nvals 2) n-word-bytes))))
+ :disp (- (* (max nvals 2) n-word-bytes))))
;; Pre-default any argument register that need it.
(when (< nvals register-arg-count)
(let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
- (first (first arg-tns)))
- (inst mov first nil-value)
- (dolist (tn (cdr arg-tns))
- (inst mov tn first))))
+ (first (first arg-tns)))
+ (inst mov first nil-value)
+ (dolist (tn (cdr arg-tns))
+ (inst mov tn first))))
;; And away we go. Except that return-pc is still on the
;; stack and we've changed the stack pointer. So we have to
;; tell it to index off of EBX instead of EBP.
(cond ((zerop nvals)
- ;; Return popping the return address and the OCFP.
- (inst ret n-word-bytes))
- ((= nvals 1)
- ;; Return popping the return, leaving 1 slot. Can this
- ;; happen, or is a single value return handled elsewhere?
- (inst ret))
- (t
- (inst jmp (make-ea :dword :base ebx
- :disp (- (* (1+ (tn-offset return-pc))
- n-word-bytes))))))
+ ;; Return popping the return address and the OCFP.
+ (inst ret n-word-bytes))
+ ((= nvals 1)
+ ;; Return popping the return, leaving 1 slot. Can this
+ ;; happen, or is a single value return handled elsewhere?
+ (inst ret))
+ (t
+ (inst jmp (make-ea :dword :base ebx
+ :disp (- (* (1+ (tn-offset return-pc))
+ n-word-bytes))))))
(trace-table-entry trace-table-normal)))
;;; ESI -- pointer to where to find the values.
(define-vop (return-multiple)
(:args (old-fp :to (:eval 1) :target old-fp-temp)
- (return-pc :target eax)
- (vals :scs (any-reg) :target esi)
- (nvals :scs (any-reg) :target ecx))
+ (return-pc :target eax)
+ (vals :scs (any-reg) :target esi)
+ (nvals :scs (any-reg) :target ecx))
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)) eax)
(:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 2)) esi)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 3)) ecx)
(:temporary (:sc unsigned-reg :offset ebx-offset :from (:eval 0)) ebx)
(:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*)
- :from (:eval 0)) a0)
+ :from (:eval 0)) a0)
(:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp)
(:node-var node)
(unless (policy node (> space speed))
;; Check for the single case.
(let ((not-single (gen-label)))
- (inst cmp nvals (fixnumize 1))
- (inst jmp :ne not-single)
-
- ;; Return with one value.
- (loadw a0 vals -1)
- ;; Clear the stack. We load old-fp into a register before clearing
- ;; the stack.
- (move old-fp-temp old-fp)
- (move esp-tn ebp-tn)
- (move ebp-tn old-fp-temp)
- ;; Fix the return-pc to point at the single-value entry point.
- (inst add eax 2)
- ;; Out of here.
- (inst jmp eax)
-
- ;; Nope, not the single case. Jump to the assembly routine.
- (emit-label not-single)))
+ (inst cmp nvals (fixnumize 1))
+ (inst jmp :ne not-single)
+
+ ;; Return with one value.
+ (loadw a0 vals -1)
+ ;; Clear the stack. We load old-fp into a register before clearing
+ ;; the stack.
+ (move old-fp-temp old-fp)
+ (move esp-tn ebp-tn)
+ (move ebp-tn old-fp-temp)
+ ;; Fix the return-pc to point at the single-value entry point.
+ (inst add eax 2)
+ ;; Out of here.
+ (inst jmp eax)
+
+ ;; Nope, not the single case. Jump to the assembly routine.
+ (emit-label not-single)))
(move esi vals)
(move ecx nvals)
(move ebx ebp-tn)
(:generator 20
;; Avoid the copy if there are no more args.
(cond ((zerop fixed)
- (inst jecxz just-alloc-frame))
- (t
- (inst cmp ecx-tn (fixnumize fixed))
- (inst jmp :be just-alloc-frame)))
+ (inst jecxz just-alloc-frame))
+ (t
+ (inst cmp ecx-tn (fixnumize fixed))
+ (inst jmp :be just-alloc-frame)))
;; Allocate the space on the stack.
;; stack = ebp - (max 3 frame-size) - (nargs - fixed)
(inst lea ebx-tn
- (make-ea :dword :base ebp-tn
- :disp (- (fixnumize fixed)
- (* n-word-bytes
- (max 3 (sb-allocated-size 'stack))))))
+ (make-ea :dword :base ebp-tn
+ :disp (- (fixnumize fixed)
+ (* n-word-bytes
+ (max 3 (sb-allocated-size 'stack))))))
(inst sub ebx-tn ecx-tn) ; Got the new stack in ebx
(inst mov esp-tn ebx-tn)
(inst mov ebx-tn ecx-tn)
(cond ((< fixed register-arg-count)
- ;; We must stop when we run out of stack args, not when we
- ;; run out of more args.
- ;; Number to copy = nargs-3
- (inst sub ecx-tn (fixnumize register-arg-count))
- ;; Everything of interest in registers.
- (inst jmp :be do-regs))
- (t
- ;; Number to copy = nargs-fixed
- (inst sub ecx-tn (fixnumize fixed))))
+ ;; We must stop when we run out of stack args, not when we
+ ;; run out of more args.
+ ;; Number to copy = nargs-3
+ (inst sub ecx-tn (fixnumize register-arg-count))
+ ;; Everything of interest in registers.
+ (inst jmp :be do-regs))
+ (t
+ ;; Number to copy = nargs-fixed
+ (inst sub ecx-tn (fixnumize fixed))))
;; Save edi and esi register args.
(inst push edi-tn)
(inst mov esi-tn ebp-tn)
(inst sub esi-tn ebx-tn)
- (inst shr ecx-tn word-shift) ; make word count
+ (inst shr ecx-tn word-shift) ; make word count
;; And copy the args.
- (inst cld) ; auto-inc ESI and EDI.
+ (inst cld) ; auto-inc ESI and EDI.
(inst rep)
(inst movs :dword)
;; Here: nargs>=1 && nargs>fixed
(when (< fixed register-arg-count)
- ;; Now we have to deposit any more args that showed up in
- ;; registers.
- (do ((i fixed))
- ( nil )
- ;; Store it relative to ebp
- (inst mov (make-ea :dword :base ebp-tn
- :disp (- (* 4
- (+ 1 (- i fixed)
- (max 3 (sb-allocated-size 'stack))))))
- (nth i *register-arg-tns*))
-
- (incf i)
- (when (>= i register-arg-count)
- (return))
-
- ;; Don't deposit any more than there are.
- (if (zerop i)
- (inst test ecx-tn ecx-tn)
- (inst cmp ecx-tn (fixnumize i)))
- (inst jmp :eq done)))
+ ;; Now we have to deposit any more args that showed up in
+ ;; registers.
+ (do ((i fixed))
+ ( nil )
+ ;; Store it relative to ebp
+ (inst mov (make-ea :dword :base ebp-tn
+ :disp (- (* 4
+ (+ 1 (- i fixed)
+ (max 3 (sb-allocated-size 'stack))))))
+ (nth i *register-arg-tns*))
+
+ (incf i)
+ (when (>= i register-arg-count)
+ (return))
+
+ ;; Don't deposit any more than there are.
+ (if (zerop i)
+ (inst test ecx-tn ecx-tn)
+ (inst cmp ecx-tn (fixnumize i)))
+ (inst jmp :eq done)))
(inst jmp done)
JUST-ALLOC-FRAME
(inst lea esp-tn
- (make-ea :dword :base ebp-tn
- :disp (- (* n-word-bytes
- (max 3 (sb-allocated-size 'stack))))))
+ (make-ea :dword :base ebp-tn
+ :disp (- (* n-word-bytes
+ (max 3 (sb-allocated-size 'stack))))))
DONE))
(:translate %more-arg)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg) :target temp))
+ (index :scs (any-reg) :target temp))
(:arg-types * tagged-num)
(:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
(:results (value :scs (any-reg descriptor-reg)))
(:result-types *)
(:generator 4
(inst mov value
- (make-ea :dword :base object :disp (- (* index n-word-bytes))))))
+ (make-ea :dword :base object :disp (- (* index n-word-bytes))))))
;;; Turn more arg (context, count) into a list.
(:translate %listify-rest-args)
(:policy :safe)
(:args (context :scs (descriptor-reg) :target src)
- (count :scs (any-reg) :target ecx))
+ (count :scs (any-reg) :target ecx))
(:arg-types * tagged-num)
(:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) src)
(:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
(:node-var node)
(:generator 20
(let ((enter (gen-label))
- (loop (gen-label))
- (done (gen-label))
+ (loop (gen-label))
+ (done (gen-label))
(stack-allocate-p (node-stack-allocate-p node)))
(move src context)
(move ecx count)
(:arg-types positive-fixnum (:constant fixnum))
(:info fixed)
(:results (context :scs (descriptor-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:result-types t tagged-num)
(:note "more-arg-context")
(:generator 5
;; SP at this point points at the last arg pushed.
;; Point to the first more-arg, not above it.
(inst lea context (make-ea :dword :base esp-tn
- :index count :scale 1
- :disp (- (+ (fixnumize fixed) 4))))
+ :index count :scale 1
+ :disp (- (+ (fixnumize fixed) 4))))
(unless (zerop fixed)
(inst sub count (fixnumize fixed)))))
(:save-p :compute-only)
(:generator 3
(let ((err-lab
- (generate-error-code vop invalid-arg-count-error nargs)))
+ (generate-error-code vop invalid-arg-count-error nargs)))
(if (zerop count)
- (inst test nargs nargs) ; smaller instruction
- (inst cmp nargs (fixnumize count)))
+ (inst test nargs nargs) ; smaller instruction
+ (inst cmp nargs (fixnumize count)))
(inst jmp :ne err-lab))))
;;; Various other error signallers.
(macrolet ((def (name error translate &rest args)
- `(define-vop (,name)
- ,@(when translate
- `((:policy :fast-safe)
- (:translate ,translate)))
- (:args ,@(mapcar (lambda (arg)
- `(,arg :scs (any-reg descriptor-reg)))
- args))
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 1000
- (error-call vop ,error ,@args)))))
+ `(define-vop (,name)
+ ,@(when translate
+ `((:policy :fast-safe)
+ (:translate ,translate)))
+ (:args ,@(mapcar (lambda (arg)
+ `(,arg :scs (any-reg descriptor-reg)))
+ args))
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1000
+ (error-call vop ,error ,@args)))))
(def arg-count-error invalid-arg-count-error
sb!c::%arg-count-error nargs)
(def type-check-error object-not-type-error sb!c::%type-check-error
(define-vop (set-slot)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg immediate)))
+ (value :scs (descriptor-reg any-reg immediate)))
(:info name offset lowtag)
(:ignore name)
(:results)
(:generator 1
(if (sc-is value immediate)
- (let ((val (tn-value value)))
- (etypecase val
- (integer
- (inst mov
- (make-ea :dword :base object
- :disp (- (* offset n-word-bytes) lowtag))
- (fixnumize val)))
- (symbol
- (inst mov
- (make-ea :dword :base object
- :disp (- (* offset n-word-bytes) lowtag))
- (+ nil-value (static-symbol-offset val))))
- (character
- (inst mov
- (make-ea :dword :base object
- :disp (- (* offset n-word-bytes) lowtag))
- (logior (ash (char-code val) n-widetag-bits)
- character-widetag)))))
+ (let ((val (tn-value value)))
+ (etypecase val
+ (integer
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* offset n-word-bytes) lowtag))
+ (fixnumize val)))
+ (symbol
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* offset n-word-bytes) lowtag))
+ (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* offset n-word-bytes) lowtag))
+ (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)))))
;; Else, value not immediate.
(storew value object offset lowtag))))
\f
;;(:policy :fast-safe)
(:generator 4
(let ((global-val (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
(inst or tls tls)
(inst jmp :z global-val)
(emit-label done))))
;; unithreaded it's a lot simpler ...
-#!-sb-thread
+#!-sb-thread
(define-vop (set cell-set)
(:variant symbol-value-slot other-pointer-lowtag))
(:save-p :compute-only)
(:generator 9
(let* ((err-lab (generate-error-code vop unbound-symbol-error object))
- (ret-lab (gen-label)))
+ (ret-lab (gen-label)))
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
(inst fs-segment-prefix)
(inst mov value (make-ea :dword :index value :scale 1))
(define-vop (locked-symbol-global-value-add)
(:args (object :scs (descriptor-reg) :to :result)
- (value :scs (any-reg) :target result))
+ (value :scs (any-reg) :target result))
(:arg-types * tagged-num)
(:results (result :scs (any-reg) :from (:argument 1)))
(:policy :fast)
(move result value)
(inst lock)
(inst add (make-ea :dword :base object
- :disp (- (* symbol-value-slot n-word-bytes)
- other-pointer-lowtag))
- value)))
+ :disp (- (* symbol-value-slot n-word-bytes)
+ other-pointer-lowtag))
+ value)))
#!+sb-thread
(define-vop (boundp)
(:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
(:generator 9
(if not-p
- (let ((not-target (gen-label)))
- (loadw value object symbol-value-slot other-pointer-lowtag)
- (inst cmp value unbound-marker-widetag)
- (inst jmp :ne not-target)
- (loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag)
- (inst jmp :e target)
- (emit-label not-target))
- (progn
- (loadw value object symbol-value-slot other-pointer-lowtag)
- (inst cmp value unbound-marker-widetag)
- (inst jmp :ne target)
- (loadw value object symbol-tls-index-slot other-pointer-lowtag)
- (inst fs-segment-prefix)
- (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag)
- (inst jmp :ne target)))))
+ (let ((not-target (gen-label)))
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (inst cmp value unbound-marker-widetag)
+ (inst jmp :ne not-target)
+ (loadw value object symbol-tls-index-slot other-pointer-lowtag)
+ (inst fs-segment-prefix)
+ (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag)
+ (inst jmp :e target)
+ (emit-label not-target))
+ (progn
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (inst cmp value unbound-marker-widetag)
+ (inst jmp :ne target)
+ (loadw value object symbol-tls-index-slot other-pointer-lowtag)
+ (inst fs-segment-prefix)
+ (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag)
+ (inst jmp :ne target)))))
#!-sb-thread
(define-vop (boundp)
\f
;;;; fdefinition (FDEFN) objects
-(define-vop (fdefn-fun cell-ref) ; /pfw - alpha
+(define-vop (fdefn-fun cell-ref) ; /pfw - alpha
(:variant fdefn-fun-slot other-pointer-lowtag))
(define-vop (safe-fdefn-fun)
(:policy :fast-safe)
(:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
- (fdefn :scs (descriptor-reg)))
+ (fdefn :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) raw)
(:temporary (:sc byte-reg) type)
(:results (result :scs (descriptor-reg)))
(:generator 38
(load-type type function (- fun-pointer-lowtag))
(inst lea raw
- (make-ea :byte :base function
- :disp (- (* simple-fun-code-offset n-word-bytes)
- fun-pointer-lowtag)))
+ (make-ea :byte :base function
+ :disp (- (* simple-fun-code-offset n-word-bytes)
+ fun-pointer-lowtag)))
(inst cmp type simple-fun-header-widetag)
(inst jmp :e normal-fn)
(inst lea raw (make-fixup "closure_tramp" :foreign))
(:generator 38
(storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
(storew (make-fixup "undefined_tramp" :foreign)
- fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+ fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(move result fdefn)))
\f
;;;; binding and unbinding
#!+sb-thread
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
- (symbol :scs (descriptor-reg)))
+ (symbol :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) tls-index temp bsp)
(:generator 5
(let ((tls-index-valid (gen-label)))
(loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(inst add bsp (* binding-size n-word-bytes))
(store-tl-symbol-value bsp *binding-stack-pointer* temp)
-
+
(inst or tls-index tls-index)
(inst jmp :ne tls-index-valid)
;; allocate a new tls-index
(load-symbol-value tls-index *free-tls-index*)
- (inst add tls-index 4) ;XXX surely we can do this more
+ (inst add tls-index 4) ;XXX surely we can do this more
(store-symbol-value tls-index *free-tls-index*) ;succintly
(inst sub tls-index 4)
(storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(emit-label tls-index-valid)
- (inst fs-segment-prefix)
+ (inst fs-segment-prefix)
(inst mov temp (make-ea :dword :scale 1 :index tls-index))
(storew temp bsp (- binding-value-slot binding-size))
(storew symbol bsp (- binding-symbol-slot binding-size))
#!+sb-thread
(define-vop (unbind)
- ;; four temporaries?
+ ;; four temporaries?
(:temporary (:sc unsigned-reg) symbol value bsp tls-index)
(:generator 0
(load-tl-symbol-value bsp *binding-stack-pointer*)
(loadw symbol bsp (- binding-symbol-slot binding-size))
(loadw value bsp (- binding-value-slot binding-size))
- (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+ (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(inst fs-segment-prefix)
(inst mov (make-ea :dword :scale 1 :index tls-index) value)
#!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag)
#!+sb-thread (loadw
- tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
+ tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
#!+sb-thread (inst fs-segment-prefix)
#!+sb-thread (inst mov (make-ea :dword :scale 1 :index tls-index) value)
(storew 0 bsp (- binding-symbol-slot binding-size))
(defknown %instance-set-conditional (instance index t t) t
- (unsafe))
+ (unsafe))
(define-vop (instance-set-conditional)
(:translate %instance-set-conditional)
(:args (object :scs (descriptor-reg) :to :eval)
- (slot :scs (any-reg) :to :result)
- (old-value :scs (descriptor-reg any-reg) :target eax)
- (new-value :scs (descriptor-reg any-reg)))
+ (slot :scs (any-reg) :to :result)
+ (old-value :scs (descriptor-reg any-reg) :target eax)
+ (new-value :scs (descriptor-reg any-reg)))
(:arg-types instance positive-fixnum * *)
(:temporary (:sc descriptor-reg :offset eax-offset
- :from (:argument 2) :to :result :target result) eax)
+ :from (:argument 2) :to :result :target result) eax)
(:results (result :scs (descriptor-reg any-reg)))
;(:guard (backend-featurep :i486))
(:policy :fast-safe)
(move eax old-value)
(inst lock)
(inst cmpxchg (make-ea :dword :base object :index slot :scale 1
- :disp (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))
- new-value)
+ :disp (- (* instance-slots-offset n-word-bytes)
+ instance-pointer-lowtag))
+ new-value)
(move result eax)))
(inst shl tmp 2)
(inst sub tmp index)
(inst mov
- value
- (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (1- instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag)))))
+ value
+ (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (1- instance-slots-offset) n-word-bytes)
+ instance-pointer-lowtag)))))
(define-vop (raw-instance-set/word)
(:translate %raw-instance-set/word)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (unsigned-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (unsigned-reg) :target result))
(:arg-types * tagged-num unsigned-num)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (unsigned-reg)))
(inst shl tmp 2)
(inst sub tmp index)
(inst mov
- (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (1- instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag))
- value)
+ (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (1- instance-slots-offset) n-word-bytes)
+ instance-pointer-lowtag))
+ value)
(move result value)))
(define-vop (raw-instance-ref/single)
(inst sub tmp index)
(with-empty-tn@fp-top(value)
(inst fld
- (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (1- instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag))))))
+ (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (1- instance-slots-offset) n-word-bytes)
+ instance-pointer-lowtag))))))
(define-vop (raw-instance-set/single)
(:translate %raw-instance-set/single)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (single-reg) :target result))
(:arg-types * tagged-num single-float)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (single-reg)))
(unless (zerop (tn-offset value))
(inst fxch value))
(inst fst
- (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (1- instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag)))
+ (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (1- instance-slots-offset) n-word-bytes)
+ instance-pointer-lowtag)))
(cond
((zerop (tn-offset value))
- (unless (zerop (tn-offset result))
- (inst fst result)))
+ (unless (zerop (tn-offset result))
+ (inst fst result)))
((zerop (tn-offset result))
- (inst fst value))
+ (inst fst value))
(t
- (unless (location= value result)
- (inst fst result))
- (inst fxch value)))))
+ (unless (location= value result)
+ (inst fst result))
+ (inst fxch value)))))
(define-vop (raw-instance-ref/double)
(:translate %raw-instance-ref/double)
(inst sub tmp index)
(with-empty-tn@fp-top(value)
(inst fldd
- (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 2) n-word-bytes)
- instance-pointer-lowtag))))))
+ (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 2) n-word-bytes)
+ instance-pointer-lowtag))))))
(define-vop (raw-instance-set/double)
(:translate %raw-instance-set/double)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (double-reg) :target result))
(:arg-types * tagged-num double-float)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (double-reg)))
(unless (zerop (tn-offset value))
(inst fxch value))
(inst fstd
- (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 2) n-word-bytes)
- instance-pointer-lowtag)))
+ (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 2) n-word-bytes)
+ instance-pointer-lowtag)))
(cond
((zerop (tn-offset value))
- (unless (zerop (tn-offset result))
- (inst fstd result)))
+ (unless (zerop (tn-offset result))
+ (inst fstd result)))
((zerop (tn-offset result))
- (inst fstd value))
+ (inst fstd value))
(t
- (unless (location= value result)
- (inst fstd result))
- (inst fxch value)))))
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))
(define-vop (raw-instance-ref/complex-single)
(:translate %raw-instance-ref/complex-single)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:temporary (:sc unsigned-reg) tmp)
(:results (value :scs (complex-single-reg)))
(inst sub tmp index)
(let ((real-tn (complex-single-reg-real-tn value)))
(with-empty-tn@fp-top (real-tn)
- (inst fld (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 2)
- n-word-bytes)
- instance-pointer-lowtag)))))
+ (inst fld (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 2)
+ n-word-bytes)
+ instance-pointer-lowtag)))))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
- (inst fld (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (1- instance-slots-offset)
- n-word-bytes)
- instance-pointer-lowtag)))))))
+ (inst fld (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (1- instance-slots-offset)
+ n-word-bytes)
+ instance-pointer-lowtag)))))))
(define-vop (raw-instance-set/complex-single)
(:translate %raw-instance-set/complex-single)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-single-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-single-reg) :target result))
(:arg-types * positive-fixnum complex-single-float)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (complex-single-reg)))
(inst shl tmp 2)
(inst sub tmp index)
(let ((value-real (complex-single-reg-real-tn value))
- (result-real (complex-single-reg-real-tn result)))
+ (result-real (complex-single-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (inst fst (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 2)
- n-word-bytes)
- instance-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fst result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (inst fst (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 2)
- n-word-bytes)
- instance-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fst value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fst result-real))
- (inst fxch value-real))))))
+ ;; Value is in ST0.
+ (inst fst (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 2)
+ n-word-bytes)
+ instance-pointer-lowtag)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fst result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fst (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 2)
+ n-word-bytes)
+ instance-pointer-lowtag)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fst value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fst result-real))
+ (inst fxch value-real))))))
(let ((value-imag (complex-single-reg-imag-tn value))
- (result-imag (complex-single-reg-imag-tn result)))
+ (result-imag (complex-single-reg-imag-tn result)))
(inst fxch value-imag)
(inst fst (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (1- instance-slots-offset)
- n-word-bytes)
- instance-pointer-lowtag)))
+ :base object
+ :index tmp
+ :disp (- (* (1- instance-slots-offset)
+ n-word-bytes)
+ instance-pointer-lowtag)))
(unless (location= value-imag result-imag)
- (inst fst result-imag))
+ (inst fst result-imag))
(inst fxch value-imag))))
(define-vop (raw-instance-ref/complex-double)
(:translate %raw-instance-ref/complex-double)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:temporary (:sc unsigned-reg) tmp)
(:results (value :scs (complex-double-reg)))
(inst sub tmp index)
(let ((real-tn (complex-double-reg-real-tn value)))
(with-empty-tn@fp-top (real-tn)
- (inst fldd (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 4)
- n-word-bytes)
- instance-pointer-lowtag)))))
+ (inst fldd (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 4)
+ n-word-bytes)
+ instance-pointer-lowtag)))))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
- (inst fldd (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 2)
- n-word-bytes)
- instance-pointer-lowtag)))))))
+ (inst fldd (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 2)
+ n-word-bytes)
+ instance-pointer-lowtag)))))))
(define-vop (raw-instance-set/complex-double)
(:translate %raw-instance-set/complex-double)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (complex-double-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-double-reg) :target result))
(:arg-types * positive-fixnum complex-double-float)
(:temporary (:sc unsigned-reg) tmp)
(:results (result :scs (complex-double-reg)))
(inst shl tmp 2)
(inst sub tmp index)
(let ((value-real (complex-double-reg-real-tn value))
- (result-real (complex-double-reg-real-tn result)))
+ (result-real (complex-double-reg-real-tn result)))
(cond ((zerop (tn-offset value-real))
- ;; Value is in ST0.
- (inst fstd (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 4)
- n-word-bytes)
- instance-pointer-lowtag)))
- (unless (zerop (tn-offset result-real))
- ;; Value is in ST0 but not result.
- (inst fstd result-real)))
- (t
- ;; Value is not in ST0.
- (inst fxch value-real)
- (inst fstd (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 4)
- n-word-bytes)
- instance-pointer-lowtag)))
- (cond ((zerop (tn-offset result-real))
- ;; The result is in ST0.
- (inst fstd value-real))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value-real result-real)
- (inst fstd result-real))
- (inst fxch value-real))))))
+ ;; Value is in ST0.
+ (inst fstd (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 4)
+ n-word-bytes)
+ instance-pointer-lowtag)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fstd result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fstd (make-ea :dword
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 4)
+ n-word-bytes)
+ instance-pointer-lowtag)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fstd value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fstd result-real))
+ (inst fxch value-real))))))
(let ((value-imag (complex-double-reg-imag-tn value))
- (result-imag (complex-double-reg-imag-tn result)))
+ (result-imag (complex-double-reg-imag-tn result)))
(inst fxch value-imag)
(inst fstd (make-ea :dword
- :base object
- :index tmp
- :disp (- (* (- instance-slots-offset 2)
- n-word-bytes)
- instance-pointer-lowtag)))
+ :base object
+ :index tmp
+ :disp (- (* (- instance-slots-offset 2)
+ n-word-bytes)
+ instance-pointer-lowtag)))
(unless (location= value-imag result-imag)
- (inst fstd result-imag))
+ (inst fstd result-imag))
(inst fxch value-imag))))
(define-vop (move-to-character)
(:args (x :scs (any-reg control-stack) :target al))
(:temporary (:sc byte-reg :offset al-offset
- :from (:argument 0) :to (:eval 0)) al)
+ :from (:argument 0) :to (:eval 0)) al)
(:ignore al)
(:temporary (:sc byte-reg :offset ah-offset :target y
- :from (:argument 0) :to (:result 0)) ah)
+ :from (:argument 0) :to (:result 0)) ah)
(:results (y :scs (character-reg character-stack)))
(:note "character untagging")
(:generator 1
(define-vop (move-from-character)
(:args (x :scs (character-reg character-stack) :target ah))
(:temporary (:sc byte-reg :offset al-offset :target y
- :from (:argument 0) :to (:result 0)) al)
+ :from (:argument 0) :to (:result 0)) al)
(:temporary (:sc byte-reg :offset ah-offset
- :from (:argument 0) :to (:result 0)) ah)
+ :from (:argument 0) :to (:result 0)) ah)
(:results (y :scs (any-reg descriptor-reg control-stack)))
(:note "character tagging")
(:generator 1
- (move ah x) ; Maybe move char byte.
- (inst mov al character-widetag) ; x86 to type bits
- (inst and eax-tn #xffff) ; Remove any junk bits.
+ (move ah x) ; Maybe move char byte.
+ (inst mov al character-widetag) ; x86 to type bits
+ (inst and eax-tn #xffff) ; Remove any junk bits.
(move y eax-tn)))
(define-move-vop move-from-character :move
(character-reg #!-sb-unicode character-stack)
;;; Move untagged character values.
(define-vop (character-move)
(:args (x :target y
- :scs (character-reg)
- :load-if (not (location= x y))))
+ :scs (character-reg)
+ :load-if (not (location= x y))))
(:results (y :scs (character-reg character-stack)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:note "character move")
(:effects)
(:affected)
;;; Move untagged character arguments/return-values.
(define-vop (move-character-arg)
(:args (x :target y
- :scs (character-reg))
- (fp :scs (any-reg)
- :load-if (not (sc-is y character-reg))))
+ :scs (character-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y character-reg))))
(:results (y))
(:note "character arg move")
(:generator 0
(character-stack
#!-sb-unicode
(inst mov
- (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 4)))
- x)
+ (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 4)))
+ x)
#!+sb-unicode
(if (= (tn-offset fp) esp-offset)
- (storew x fp (tn-offset y)) ; c-call
- (storew x fp (- (1+ (tn-offset y)))))))))
+ (storew x fp (tn-offset y)) ; c-call
+ (storew x fp (- (1+ (tn-offset y)))))))))
(define-move-vop move-character-arg :move-arg
(any-reg character-reg) (character-reg))
(:args (code :scs (unsigned-reg unsigned-stack) :target eax))
(:arg-types positive-fixnum)
(:temporary (:sc unsigned-reg :offset eax-offset :target res
- :from (:argument 0) :to (:result 0))
- eax)
+ :from (:argument 0) :to (:result 0))
+ eax)
(:results (res :scs (character-reg)))
(:result-types character)
(:generator 1
;;; comparison of CHARACTERs
(define-vop (character-compare)
(:args (x :scs (character-reg character-stack))
- (y :scs (character-reg)
- :load-if (not (and (sc-is x character-reg)
- (sc-is y character-stack)))))
+ (y :scs (character-reg)
+ :load-if (not (and (sc-is x character-reg)
+ (sc-is y character-stack)))))
(:arg-types character character)
(:conditional)
(:info target not-p)
(:translate stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to :eval)
- (offset :scs (any-reg) :target temp))
+ (offset :scs (any-reg) :target temp))
(:arg-types system-area-pointer positive-fixnum)
(:temporary (:sc unsigned-reg :from (:argument 1)) temp)
(:results (result :scs (descriptor-reg)))
(move temp offset)
(inst neg temp)
(inst mov result
- (make-ea :dword :base sap :disp (- n-word-bytes) :index temp))))
+ (make-ea :dword :base sap :disp (- n-word-bytes) :index temp))))
(define-vop (read-control-stack-c)
(:translate stack-ref)
(:result-types *)
(:generator 5
(inst mov result (make-ea :dword :base sap
- :disp (- (* (1+ index) n-word-bytes))))))
+ :disp (- (* (1+ index) n-word-bytes))))))
(define-vop (write-control-stack)
(:translate %set-stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to :eval)
- (offset :scs (any-reg) :target temp)
- (value :scs (descriptor-reg) :to :result :target result))
+ (offset :scs (any-reg) :target temp)
+ (value :scs (descriptor-reg) :to :result :target result))
(:arg-types system-area-pointer positive-fixnum *)
(:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
(:results (result :scs (descriptor-reg)))
(move temp offset)
(inst neg temp)
(inst mov
- (make-ea :dword :base sap :disp (- n-word-bytes) :index temp) value)
+ (make-ea :dword :base sap :disp (- n-word-bytes) :index temp) value)
(move result value)))
(define-vop (write-control-stack-c)
(:translate %set-stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (value :scs (descriptor-reg) :target result))
+ (value :scs (descriptor-reg) :target result))
(:info index)
(:arg-types system-area-pointer (:constant (signed-byte 30)) *)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:generator 5
(inst mov (make-ea :dword :base sap
- :disp (- (* (1+ index) n-word-bytes)))
- value)
+ :disp (- (* (1+ index) n-word-bytes)))
+ value)
(move result value)))
(define-vop (code-from-mumble)
(:variant-vars lowtag)
(:generator 5
(let ((bogus (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(loadw temp thing 0 lowtag)
(inst shr temp n-widetag-bits)
(inst jmp :z bogus)
(inst shl temp (1- (integer-length n-word-bytes)))
(unless (= lowtag other-pointer-lowtag)
- (inst add temp (- lowtag other-pointer-lowtag)))
+ (inst add temp (- lowtag other-pointer-lowtag)))
(move code thing)
(inst sub code temp)
(emit-label done)
(assemble (*elsewhere*)
- (emit-label bogus)
- (inst mov code nil-value)
- (inst jmp done)))))
+ (emit-label bogus)
+ (inst mov code nil-value)
+ (inst jmp done)))))
(define-vop (code-from-lra code-from-mumble)
(:translate sb!di::lra-code-header)
(:args (value :scs (unsigned-reg unsigned-stack) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)
- :load-if (not (sc-is value unsigned-reg))
- ))
+ :load-if (not (sc-is value unsigned-reg))
+ ))
(:generator 1
(move result value)))
(:translate sb!di::get-lisp-obj-address)
(:args (thing :scs (descriptor-reg control-stack) :target result))
(:results (result :scs (unsigned-reg)
- :load-if (not (and (sc-is thing descriptor-reg)
- (sc-is result unsigned-stack)))))
+ :load-if (not (and (sc-is thing descriptor-reg)
+ (sc-is result unsigned-stack)))))
(:result-types unsigned-num)
(:generator 1
(move result thing)))
(in-package "SB!VM")
\f
(macrolet ((ea-for-xf-desc (tn slot)
- `(make-ea
- :dword :base ,tn
- :disp (- (* ,slot n-word-bytes)
- other-pointer-lowtag))))
+ `(make-ea
+ :dword :base ,tn
+ :disp (- (* ,slot n-word-bytes)
+ other-pointer-lowtag))))
(defun ea-for-sf-desc (tn)
(ea-for-xf-desc tn single-float-value-slot))
(defun ea-for-df-desc (tn)
(ea-for-xf-desc tn complex-long-float-imag-slot)))
(macrolet ((ea-for-xf-stack (tn kind)
- `(make-ea
- :dword :base ebp-tn
- :disp (- (* (+ (tn-offset ,tn)
- (ecase ,kind (:single 1) (:double 2) (:long 3)))
- n-word-bytes)))))
+ `(make-ea
+ :dword :base ebp-tn
+ :disp (- (* (+ (tn-offset ,tn)
+ (ecase ,kind (:single 1) (:double 2) (:long 3)))
+ n-word-bytes)))))
(defun ea-for-sf-stack (tn)
(ea-for-xf-stack tn :single))
(defun ea-for-df-stack (tn)
;;; complex float stack EAs
(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
- `(make-ea
- :dword :base ,base
- :disp (- (* (+ (tn-offset ,tn)
- (* (ecase ,kind
- (:single 1)
- (:double 2)
- (:long 3))
- (ecase ,slot (:real 1) (:imag 2))))
- n-word-bytes)))))
+ `(make-ea
+ :dword :base ,base
+ :disp (- (* (+ (tn-offset ,tn)
+ (* (ecase ,kind
+ (:single 1)
+ (:double 2)
+ (:long 3))
+ (ecase ,slot (:real 1) (:imag 2))))
+ n-word-bytes)))))
(defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
(ea-for-cxf-stack tn :single :real base))
(defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
(aver (not (zerop (tn-offset reg))))
(inst fstp fr0-tn)
(inst fld (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset reg)))))
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset reg)))))
;;; Using Fxch then Fst to restore the original reg contents.
#+nil
(defun copy-fp-reg-to-fr0 (reg)
(define-move-fun (store-single 2) (vop x y)
((single-reg) (single-stack))
(cond ((zerop (tn-offset x))
- (inst fst (ea-for-sf-stack y)))
- (t
- (inst fxch x)
- (inst fst (ea-for-sf-stack y))
- ;; This may not be necessary as ST0 is likely invalid now.
- (inst fxch x))))
+ (inst fst (ea-for-sf-stack y)))
+ (t
+ (inst fxch x)
+ (inst fst (ea-for-sf-stack y))
+ ;; This may not be necessary as ST0 is likely invalid now.
+ (inst fxch x))))
(define-move-fun (load-double 2) (vop x y)
((double-stack) (double-reg))
(define-move-fun (store-double 2) (vop x y)
((double-reg) (double-stack))
(cond ((zerop (tn-offset x))
- (inst fstd (ea-for-df-stack y)))
- (t
- (inst fxch x)
- (inst fstd (ea-for-df-stack y))
- ;; This may not be necessary as ST0 is likely invalid now.
- (inst fxch x))))
+ (inst fstd (ea-for-df-stack y)))
+ (t
+ (inst fxch x)
+ (inst fstd (ea-for-df-stack y))
+ ;; This may not be necessary as ST0 is likely invalid now.
+ (inst fxch x))))
#!+long-float
(define-move-fun (load-long 2) (vop x y)
(define-move-fun (store-long 2) (vop x y)
((long-reg) (long-stack))
(cond ((zerop (tn-offset x))
- (store-long-float (ea-for-lf-stack y)))
- (t
- (inst fxch x)
- (store-long-float (ea-for-lf-stack y))
- ;; This may not be necessary as ST0 is likely invalid now.
- (inst fxch x))))
+ (store-long-float (ea-for-lf-stack y)))
+ (t
+ (inst fxch x)
+ (store-long-float (ea-for-lf-stack y))
+ ;; This may not be necessary as ST0 is likely invalid now.
+ (inst fxch x))))
;;; The i387 has instructions to load some useful constants. This
;;; doesn't save much time but might cut down on memory access and
;;; "immediate-constant-sc" in vm.lisp.
(eval-when (:compile-toplevel :execute)
(setf *read-default-float-format*
- #!+long-float 'long-float #!-long-float 'double-float))
+ #!+long-float 'long-float #!-long-float 'double-float))
(define-move-fun (load-fp-constant 2) (vop x y)
((fp-constant) (single-reg double-reg #!+long-float long-reg))
(let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
(with-empty-tn@fp-top(y)
(cond ((zerop value)
- (inst fldz))
- ((= value 1e0)
- (inst fld1))
- ((= value (coerce pi *read-default-float-format*))
- (inst fldpi))
- ((= value (log 10e0 2e0))
- (inst fldl2t))
- ((= value (log 2.718281828459045235360287471352662e0 2e0))
- (inst fldl2e))
- ((= value (log 2e0 10e0))
- (inst fldlg2))
- ((= value (log 2e0 2.718281828459045235360287471352662e0))
- (inst fldln2))
- (t (warn "ignoring bogus i387 constant ~A" value))))))
+ (inst fldz))
+ ((= value 1e0)
+ (inst fld1))
+ ((= value (coerce pi *read-default-float-format*))
+ (inst fldpi))
+ ((= value (log 10e0 2e0))
+ (inst fldl2t))
+ ((= value (log 2.718281828459045235360287471352662e0 2e0))
+ (inst fldl2e))
+ ((= value (log 2e0 10e0))
+ (inst fldlg2))
+ ((= value (log 2e0 2.718281828459045235360287471352662e0))
+ (inst fldln2))
+ (t (warn "ignoring bogus i387 constant ~A" value))))))
(eval-when (:compile-toplevel :execute)
(setf *read-default-float-format* 'single-float))
\f
(defun complex-single-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
- :offset (tn-offset x)))
+ :offset (tn-offset x)))
(defun complex-single-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
- :offset (1+ (tn-offset x))))
+ :offset (1+ (tn-offset x))))
(defun complex-double-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
- :offset (tn-offset x)))
+ :offset (tn-offset x)))
(defun complex-double-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
- :offset (1+ (tn-offset x))))
+ :offset (1+ (tn-offset x))))
#!+long-float
(defun complex-long-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
- :offset (tn-offset x)))
+ :offset (tn-offset x)))
#!+long-float
(defun complex-long-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
- :offset (1+ (tn-offset x))))
+ :offset (1+ (tn-offset x))))
;;; X is source, Y is destination.
(define-move-fun (load-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((real-tn (complex-single-reg-real-tn x)))
(cond ((zerop (tn-offset real-tn))
- (inst fst (ea-for-csf-real-stack y)))
- (t
- (inst fxch real-tn)
- (inst fst (ea-for-csf-real-stack y))
- (inst fxch real-tn))))
+ (inst fst (ea-for-csf-real-stack y)))
+ (t
+ (inst fxch real-tn)
+ (inst fst (ea-for-csf-real-stack y))
+ (inst fxch real-tn))))
(let ((imag-tn (complex-single-reg-imag-tn x)))
(inst fxch imag-tn)
(inst fst (ea-for-csf-imag-stack y))
((complex-double-reg) (complex-double-stack))
(let ((real-tn (complex-double-reg-real-tn x)))
(cond ((zerop (tn-offset real-tn))
- (inst fstd (ea-for-cdf-real-stack y)))
- (t
- (inst fxch real-tn)
- (inst fstd (ea-for-cdf-real-stack y))
- (inst fxch real-tn))))
+ (inst fstd (ea-for-cdf-real-stack y)))
+ (t
+ (inst fxch real-tn)
+ (inst fstd (ea-for-cdf-real-stack y))
+ (inst fxch real-tn))))
(let ((imag-tn (complex-double-reg-imag-tn x)))
(inst fxch imag-tn)
(inst fstd (ea-for-cdf-imag-stack y))
((complex-long-reg) (complex-long-stack))
(let ((real-tn (complex-long-reg-real-tn x)))
(cond ((zerop (tn-offset real-tn))
- (store-long-float (ea-for-clf-real-stack y)))
- (t
- (inst fxch real-tn)
- (store-long-float (ea-for-clf-real-stack y))
- (inst fxch real-tn))))
+ (store-long-float (ea-for-clf-real-stack y)))
+ (t
+ (inst fxch real-tn)
+ (store-long-float (ea-for-clf-real-stack y))
+ (inst fxch real-tn))))
(let ((imag-tn (complex-long-reg-imag-tn x)))
(inst fxch imag-tn)
(store-long-float (ea-for-clf-imag-stack y))
(:note "float move")
(:generator 0
(unless (location= x y)
- (cond ((zerop (tn-offset y))
- (copy-fp-reg-to-fr0 x))
- ((zerop (tn-offset x))
- (inst fstd y))
- (t
- (inst fxch x)
- (inst fstd y)
- (inst fxch x))))))
+ (cond ((zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 x))
+ ((zerop (tn-offset x))
+ (inst fstd y))
+ (t
+ (inst fxch x)
+ (inst fstd y)
+ (inst fxch x))))))
(define-vop (single-move float-move)
(:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
;; Note the complex-float-regs are aligned to every second
;; float register so there is not need to worry about overlap.
(let ((x-real (complex-double-reg-real-tn x))
- (y-real (complex-double-reg-real-tn y)))
- (cond ((zerop (tn-offset y-real))
- (copy-fp-reg-to-fr0 x-real))
- ((zerop (tn-offset x-real))
- (inst fstd y-real))
- (t
- (inst fxch x-real)
- (inst fstd y-real)
- (inst fxch x-real))))
+ (y-real (complex-double-reg-real-tn y)))
+ (cond ((zerop (tn-offset y-real))
+ (copy-fp-reg-to-fr0 x-real))
+ ((zerop (tn-offset x-real))
+ (inst fstd y-real))
+ (t
+ (inst fxch x-real)
+ (inst fstd y-real)
+ (inst fxch x-real))))
(let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (inst fxch x-imag)
- (inst fstd y-imag)
- (inst fxch x-imag)))))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fxch x-imag)
+ (inst fstd y-imag)
+ (inst fxch x-imag)))))
(define-vop (complex-single-move complex-float-move)
(:args (x :scs (complex-single-reg) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
(define-move-vop complex-single-move :move
(complex-single-reg) (complex-single-reg))
(define-vop (complex-double-move complex-float-move)
(:args (x :scs (complex-double-reg)
- :target y :load-if (not (location= x y))))
+ :target y :load-if (not (location= x y))))
(:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
(define-move-vop complex-double-move :move
(complex-double-reg) (complex-double-reg))
#!+long-float
(define-vop (complex-long-move complex-float-move)
(:args (x :scs (complex-long-reg)
- :target y :load-if (not (location= x y))))
+ :target y :load-if (not (location= x y))))
(:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
#!+long-float
(define-move-vop complex-long-move :move
(:note "float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- single-float-widetag
- single-float-size node)
+ single-float-widetag
+ single-float-size node)
(with-tn@fp-top(x)
- (inst fst (ea-for-sf-desc y))))))
+ (inst fst (ea-for-sf-desc y))))))
(define-move-vop move-from-single :move
(single-reg) (descriptor-reg))
(:note "float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- double-float-widetag
- double-float-size
- node)
+ double-float-widetag
+ double-float-size
+ node)
(with-tn@fp-top(x)
- (inst fstd (ea-for-df-desc y))))))
+ (inst fstd (ea-for-df-desc y))))))
(define-move-vop move-from-double :move
(double-reg) (descriptor-reg))
(:note "float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- long-float-widetag
- long-float-size
- node)
+ long-float-widetag
+ long-float-size
+ node)
(with-tn@fp-top(x)
- (store-long-float (ea-for-lf-desc y))))))
+ (store-long-float (ea-for-lf-desc y))))))
#!+long-float
(define-move-vop move-from-long :move
(long-reg) (descriptor-reg))
(#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
#!+long-float
(#.(log 2.718281828459045235360287471352662L0 2l0)
- (load-symbol-value y *fp-constant-l2e*))
+ (load-symbol-value y *fp-constant-l2e*))
#!+long-float
(#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
#!+long-float
(#.(log 2l0 2.718281828459045235360287471352662L0)
- (load-symbol-value y *fp-constant-ln2*)))))
+ (load-symbol-value y *fp-constant-ln2*)))))
(define-move-vop move-from-fp-constant :move
(fp-constant) (descriptor-reg))
(:note "complex float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- complex-single-float-widetag
- complex-single-float-size
- node)
+ complex-single-float-widetag
+ complex-single-float-size
+ node)
(let ((real-tn (complex-single-reg-real-tn x)))
- (with-tn@fp-top(real-tn)
- (inst fst (ea-for-csf-real-desc y))))
+ (with-tn@fp-top(real-tn)
+ (inst fst (ea-for-csf-real-desc y))))
(let ((imag-tn (complex-single-reg-imag-tn x)))
- (with-tn@fp-top(imag-tn)
- (inst fst (ea-for-csf-imag-desc y)))))))
+ (with-tn@fp-top(imag-tn)
+ (inst fst (ea-for-csf-imag-desc y)))))))
(define-move-vop move-from-complex-single :move
(complex-single-reg) (descriptor-reg))
(:note "complex float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- complex-double-float-widetag
- complex-double-float-size
- node)
+ complex-double-float-widetag
+ complex-double-float-size
+ node)
(let ((real-tn (complex-double-reg-real-tn x)))
- (with-tn@fp-top(real-tn)
- (inst fstd (ea-for-cdf-real-desc y))))
+ (with-tn@fp-top(real-tn)
+ (inst fstd (ea-for-cdf-real-desc y))))
(let ((imag-tn (complex-double-reg-imag-tn x)))
- (with-tn@fp-top(imag-tn)
- (inst fstd (ea-for-cdf-imag-desc y)))))))
+ (with-tn@fp-top(imag-tn)
+ (inst fstd (ea-for-cdf-imag-desc y)))))))
(define-move-vop move-from-complex-double :move
(complex-double-reg) (descriptor-reg))
(:note "complex float to pointer coercion")
(:generator 13
(with-fixed-allocation (y
- complex-long-float-widetag
- complex-long-float-size
- node)
+ complex-long-float-widetag
+ complex-long-float-size
+ node)
(let ((real-tn (complex-long-reg-real-tn x)))
- (with-tn@fp-top(real-tn)
- (store-long-float (ea-for-clf-real-desc y))))
+ (with-tn@fp-top(real-tn)
+ (store-long-float (ea-for-clf-real-desc y))))
(let ((imag-tn (complex-long-reg-imag-tn x)))
- (with-tn@fp-top(imag-tn)
- (store-long-float (ea-for-clf-imag-desc y)))))))
+ (with-tn@fp-top(imag-tn)
+ (store-long-float (ea-for-clf-imag-desc y)))))))
#!+long-float
(define-move-vop move-from-complex-long :move
(complex-long-reg) (descriptor-reg))
;;; Move from a descriptor to a complex float register.
(macrolet ((frob (name sc format)
- `(progn
- (define-vop (,name)
- (:args (x :scs (descriptor-reg)))
- (:results (y :scs (,sc)))
- (:note "pointer to complex float coercion")
- (:generator 2
- (let ((real-tn (complex-double-reg-real-tn y)))
- (with-empty-tn@fp-top(real-tn)
- ,@(ecase format
- (:single '((inst fld (ea-for-csf-real-desc x))))
- (:double '((inst fldd (ea-for-cdf-real-desc x))))
- #!+long-float
- (:long '((inst fldl (ea-for-clf-real-desc x)))))))
- (let ((imag-tn (complex-double-reg-imag-tn y)))
- (with-empty-tn@fp-top(imag-tn)
- ,@(ecase format
- (:single '((inst fld (ea-for-csf-imag-desc x))))
- (:double '((inst fldd (ea-for-cdf-imag-desc x))))
- #!+long-float
- (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
- (define-move-vop ,name :move (descriptor-reg) (,sc)))))
- (frob move-to-complex-single complex-single-reg :single)
- (frob move-to-complex-double complex-double-reg :double)
- #!+long-float
- (frob move-to-complex-double complex-long-reg :long))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (,sc)))
+ (:note "pointer to complex float coercion")
+ (:generator 2
+ (let ((real-tn (complex-double-reg-real-tn y)))
+ (with-empty-tn@fp-top(real-tn)
+ ,@(ecase format
+ (:single '((inst fld (ea-for-csf-real-desc x))))
+ (:double '((inst fldd (ea-for-cdf-real-desc x))))
+ #!+long-float
+ (:long '((inst fldl (ea-for-clf-real-desc x)))))))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (with-empty-tn@fp-top(imag-tn)
+ ,@(ecase format
+ (:single '((inst fld (ea-for-csf-imag-desc x))))
+ (:double '((inst fldd (ea-for-cdf-imag-desc x))))
+ #!+long-float
+ (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ (frob move-to-complex-single complex-single-reg :single)
+ (frob move-to-complex-double complex-double-reg :double)
+ #!+long-float
+ (frob move-to-complex-double complex-long-reg :long))
\f
;;;; the move argument vops
;;;;
;;; the general MOVE-ARG VOP
(macrolet ((frob (name sc stack-sc format)
- `(progn
- (define-vop (,name)
- (:args (x :scs (,sc) :target y)
- (fp :scs (any-reg)
- :load-if (not (sc-is y ,sc))))
- (:results (y))
- (:note "float argument move")
- (:generator ,(case format (:single 2) (:double 3) (:long 4))
- (sc-case y
- (,sc
- (unless (location= x y)
- (cond ((zerop (tn-offset y))
- (copy-fp-reg-to-fr0 x))
- ((zerop (tn-offset x))
- (inst fstd y))
- (t
- (inst fxch x)
- (inst fstd y)
- (inst fxch x)))))
- (,stack-sc
- (if (= (tn-offset fp) esp-offset)
- (let* ((offset (* (tn-offset y) n-word-bytes))
- (ea (make-ea :dword :base fp :disp offset)))
- (with-tn@fp-top(x)
- ,@(ecase format
- (:single '((inst fst ea)))
- (:double '((inst fstd ea)))
- #!+long-float
- (:long '((store-long-float ea))))))
- (let ((ea (make-ea
- :dword :base fp
- :disp (- (* (+ (tn-offset y)
- ,(case format
- (:single 1)
- (:double 2)
- (:long 3)))
- n-word-bytes)))))
- (with-tn@fp-top(x)
- ,@(ecase format
- (:single '((inst fst ea)))
- (:double '((inst fstd ea)))
- #!+long-float
- (:long '((store-long-float ea)))))))))))
- (define-move-vop ,name :move-arg
- (,sc descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "float argument move")
+ (:generator ,(case format (:single 2) (:double 3) (:long 4))
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (cond ((zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 x))
+ ((zerop (tn-offset x))
+ (inst fstd y))
+ (t
+ (inst fxch x)
+ (inst fstd y)
+ (inst fxch x)))))
+ (,stack-sc
+ (if (= (tn-offset fp) esp-offset)
+ (let* ((offset (* (tn-offset y) n-word-bytes))
+ (ea (make-ea :dword :base fp :disp offset)))
+ (with-tn@fp-top(x)
+ ,@(ecase format
+ (:single '((inst fst ea)))
+ (:double '((inst fstd ea)))
+ #!+long-float
+ (:long '((store-long-float ea))))))
+ (let ((ea (make-ea
+ :dword :base fp
+ :disp (- (* (+ (tn-offset y)
+ ,(case format
+ (:single 1)
+ (:double 2)
+ (:long 3)))
+ n-word-bytes)))))
+ (with-tn@fp-top(x)
+ ,@(ecase format
+ (:single '((inst fst ea)))
+ (:double '((inst fstd ea)))
+ #!+long-float
+ (:long '((store-long-float ea)))))))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
(frob move-single-float-arg single-reg single-stack :single)
(frob move-double-float-arg double-reg double-stack :double)
#!+long-float
;;;; complex float MOVE-ARG VOP
(macrolet ((frob (name sc stack-sc format)
- `(progn
- (define-vop (,name)
- (:args (x :scs (,sc) :target y)
- (fp :scs (any-reg)
- :load-if (not (sc-is y ,sc))))
- (:results (y))
- (:note "complex float argument move")
- (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
- (sc-case y
- (,sc
- (unless (location= x y)
- (let ((x-real (complex-double-reg-real-tn x))
- (y-real (complex-double-reg-real-tn y)))
- (cond ((zerop (tn-offset y-real))
- (copy-fp-reg-to-fr0 x-real))
- ((zerop (tn-offset x-real))
- (inst fstd y-real))
- (t
- (inst fxch x-real)
- (inst fstd y-real)
- (inst fxch x-real))))
- (let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (inst fxch x-imag)
- (inst fstd y-imag)
- (inst fxch x-imag))))
- (,stack-sc
- (let ((real-tn (complex-double-reg-real-tn x)))
- (cond ((zerop (tn-offset real-tn))
- ,@(ecase format
- (:single
- '((inst fst
- (ea-for-csf-real-stack y fp))))
- (:double
- '((inst fstd
- (ea-for-cdf-real-stack y fp))))
- #!+long-float
- (:long
- '((store-long-float
- (ea-for-clf-real-stack y fp))))))
- (t
- (inst fxch real-tn)
- ,@(ecase format
- (:single
- '((inst fst
- (ea-for-csf-real-stack y fp))))
- (:double
- '((inst fstd
- (ea-for-cdf-real-stack y fp))))
- #!+long-float
- (:long
- '((store-long-float
- (ea-for-clf-real-stack y fp)))))
- (inst fxch real-tn))))
- (let ((imag-tn (complex-double-reg-imag-tn x)))
- (inst fxch imag-tn)
- ,@(ecase format
- (:single
- '((inst fst (ea-for-csf-imag-stack y fp))))
- (:double
- '((inst fstd (ea-for-cdf-imag-stack y fp))))
- #!+long-float
- (:long
- '((store-long-float
- (ea-for-clf-imag-stack y fp)))))
- (inst fxch imag-tn))))))
- (define-move-vop ,name :move-arg
- (,sc descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "complex float argument move")
+ (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (cond ((zerop (tn-offset y-real))
+ (copy-fp-reg-to-fr0 x-real))
+ ((zerop (tn-offset x-real))
+ (inst fstd y-real))
+ (t
+ (inst fxch x-real)
+ (inst fstd y-real)
+ (inst fxch x-real))))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fxch x-imag)
+ (inst fstd y-imag)
+ (inst fxch x-imag))))
+ (,stack-sc
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (cond ((zerop (tn-offset real-tn))
+ ,@(ecase format
+ (:single
+ '((inst fst
+ (ea-for-csf-real-stack y fp))))
+ (:double
+ '((inst fstd
+ (ea-for-cdf-real-stack y fp))))
+ #!+long-float
+ (:long
+ '((store-long-float
+ (ea-for-clf-real-stack y fp))))))
+ (t
+ (inst fxch real-tn)
+ ,@(ecase format
+ (:single
+ '((inst fst
+ (ea-for-csf-real-stack y fp))))
+ (:double
+ '((inst fstd
+ (ea-for-cdf-real-stack y fp))))
+ #!+long-float
+ (:long
+ '((store-long-float
+ (ea-for-clf-real-stack y fp)))))
+ (inst fxch real-tn))))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst fxch imag-tn)
+ ,@(ecase format
+ (:single
+ '((inst fst (ea-for-csf-imag-stack y fp))))
+ (:double
+ '((inst fstd (ea-for-cdf-imag-stack y fp))))
+ #!+long-float
+ (:long
+ '((store-long-float
+ (ea-for-clf-imag-stack y fp)))))
+ (inst fxch imag-tn))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
(frob move-complex-single-float-arg
- complex-single-reg complex-single-stack :single)
+ complex-single-reg complex-single-stack :single)
(frob move-complex-double-float-arg
- complex-double-reg complex-double-stack :double)
+ complex-double-reg complex-double-stack :double)
#!+long-float
(frob move-complex-long-float-arg
- complex-long-reg complex-long-stack :long))
+ complex-long-reg complex-long-stack :long))
(define-move-vop move-arg :move-arg
(single-reg double-reg #!+long-float long-reg
;;;
;;; (defun test(a n)
;;; (declare (type (simple-array double-float (*)) a)
-;;; (fixnum n))
+;;; (fixnum n))
;;; (let ((sum 0d0))
;;; (declare (type double-float sum))
;;; (dotimes (i n)
;;; So, disabling descriptor args until this can be fixed elsewhere.
(macrolet
((frob (op fop-sti fopr-sti
- fop fopr sname scost
- fopd foprd dname dcost
- lname lcost)
+ fop fopr sname scost
+ fopd foprd dname dcost
+ lname lcost)
#!-long-float (declare (ignore lcost lname))
`(progn
- (define-vop (,sname)
- (:translate ,op)
- (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
- :to :eval)
- (y :scs (single-reg single-stack #+nil descriptor-reg)
- :to :eval))
- (:temporary (:sc single-reg :offset fr0-offset
- :from :eval :to :result) fr0)
- (:results (r :scs (single-reg single-stack)))
- (:arg-types single-float single-float)
- (:result-types single-float)
- (:policy :fast-safe)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator ,scost
- ;; Handle a few special cases
- (cond
- ;; x, y, and r are the same register.
- ((and (sc-is x single-reg) (location= x r) (location= y r))
- (cond ((zerop (tn-offset r))
- (inst ,fop fr0))
- (t
- (inst fxch r)
- (inst ,fop fr0)
- ;; XX the source register will not be valid.
- (note-next-instruction vop :internal-error)
- (inst fxch r))))
-
- ;; x and r are the same register.
- ((and (sc-is x single-reg) (location= x r))
- (cond ((zerop (tn-offset r))
- (sc-case y
- (single-reg
- ;; ST(0) = ST(0) op ST(y)
- (inst ,fop y))
- (single-stack
- ;; ST(0) = ST(0) op Mem
- (inst ,fop (ea-for-sf-stack y)))
- (descriptor-reg
- (inst ,fop (ea-for-sf-desc y)))))
- (t
- ;; y to ST0
- (sc-case y
- (single-reg
- (unless (zerop (tn-offset y))
- (copy-fp-reg-to-fr0 y)))
- ((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is y single-stack)
- (inst fld (ea-for-sf-stack y))
- (inst fld (ea-for-sf-desc y)))))
- ;; ST(i) = ST(i) op ST0
- (inst ,fop-sti r)))
- (maybe-fp-wait node vop))
- ;; y and r are the same register.
- ((and (sc-is y single-reg) (location= y r))
- (cond ((zerop (tn-offset r))
- (sc-case x
- (single-reg
- ;; ST(0) = ST(x) op ST(0)
- (inst ,fopr x))
- (single-stack
- ;; ST(0) = Mem op ST(0)
- (inst ,fopr (ea-for-sf-stack x)))
- (descriptor-reg
- (inst ,fopr (ea-for-sf-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (single-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x single-stack)
- (inst fld (ea-for-sf-stack x))
- (inst fld (ea-for-sf-desc x)))))
- ;; ST(i) = ST(0) op ST(i)
- (inst ,fopr-sti r)))
- (maybe-fp-wait node vop))
- ;; the default case
- (t
- ;; Get the result to ST0.
-
- ;; Special handling is needed if x or y are in ST0, and
- ;; simpler code is generated.
- (cond
- ;; x is in ST0
- ((and (sc-is x single-reg) (zerop (tn-offset x)))
- ;; ST0 = ST0 op y
- (sc-case y
- (single-reg
- (inst ,fop y))
- (single-stack
- (inst ,fop (ea-for-sf-stack y)))
- (descriptor-reg
- (inst ,fop (ea-for-sf-desc y)))))
- ;; y is in ST0
- ((and (sc-is y single-reg) (zerop (tn-offset y)))
- ;; ST0 = x op ST0
- (sc-case x
- (single-reg
- (inst ,fopr x))
- (single-stack
- (inst ,fopr (ea-for-sf-stack x)))
- (descriptor-reg
- (inst ,fopr (ea-for-sf-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (single-reg
- (copy-fp-reg-to-fr0 x))
- (single-stack
- (inst fstp fr0)
- (inst fld (ea-for-sf-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fld (ea-for-sf-desc x))))
- ;; ST0 = ST0 op y
- (sc-case y
- (single-reg
- (inst ,fop y))
- (single-stack
- (inst ,fop (ea-for-sf-stack y)))
- (descriptor-reg
- (inst ,fop (ea-for-sf-desc y))))))
-
- (note-next-instruction vop :internal-error)
-
- ;; Finally save the result.
- (sc-case r
- (single-reg
- (cond ((zerop (tn-offset r))
- (maybe-fp-wait node))
- (t
- (inst fst r))))
- (single-stack
- (inst fst (ea-for-sf-stack r))))))))
-
- (define-vop (,dname)
- (:translate ,op)
- (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
- :to :eval)
- (y :scs (double-reg double-stack #+nil descriptor-reg)
- :to :eval))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :eval :to :result) fr0)
- (:results (r :scs (double-reg double-stack)))
- (:arg-types double-float double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator ,dcost
- ;; Handle a few special cases.
- (cond
- ;; x, y, and r are the same register.
- ((and (sc-is x double-reg) (location= x r) (location= y r))
- (cond ((zerop (tn-offset r))
- (inst ,fop fr0))
- (t
- (inst fxch x)
- (inst ,fopd fr0)
- ;; XX the source register will not be valid.
- (note-next-instruction vop :internal-error)
- (inst fxch r))))
-
- ;; x and r are the same register.
- ((and (sc-is x double-reg) (location= x r))
- (cond ((zerop (tn-offset r))
- (sc-case y
- (double-reg
- ;; ST(0) = ST(0) op ST(y)
- (inst ,fopd y))
- (double-stack
- ;; ST(0) = ST(0) op Mem
- (inst ,fopd (ea-for-df-stack y)))
- (descriptor-reg
- (inst ,fopd (ea-for-df-desc y)))))
- (t
- ;; y to ST0
- (sc-case y
- (double-reg
- (unless (zerop (tn-offset y))
- (copy-fp-reg-to-fr0 y)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is y double-stack)
- (inst fldd (ea-for-df-stack y))
- (inst fldd (ea-for-df-desc y)))))
- ;; ST(i) = ST(i) op ST0
- (inst ,fop-sti r)))
- (maybe-fp-wait node vop))
- ;; y and r are the same register.
- ((and (sc-is y double-reg) (location= y r))
- (cond ((zerop (tn-offset r))
- (sc-case x
- (double-reg
- ;; ST(0) = ST(x) op ST(0)
- (inst ,foprd x))
- (double-stack
- ;; ST(0) = Mem op ST(0)
- (inst ,foprd (ea-for-df-stack x)))
- (descriptor-reg
- (inst ,foprd (ea-for-df-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (double-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
- ;; ST(i) = ST(0) op ST(i)
- (inst ,fopr-sti r)))
- (maybe-fp-wait node vop))
- ;; the default case
- (t
- ;; Get the result to ST0.
-
- ;; Special handling is needed if x or y are in ST0, and
- ;; simpler code is generated.
- (cond
- ;; x is in ST0
- ((and (sc-is x double-reg) (zerop (tn-offset x)))
- ;; ST0 = ST0 op y
- (sc-case y
- (double-reg
- (inst ,fopd y))
- (double-stack
- (inst ,fopd (ea-for-df-stack y)))
- (descriptor-reg
- (inst ,fopd (ea-for-df-desc y)))))
- ;; y is in ST0
- ((and (sc-is y double-reg) (zerop (tn-offset y)))
- ;; ST0 = x op ST0
- (sc-case x
- (double-reg
- (inst ,foprd x))
- (double-stack
- (inst ,foprd (ea-for-df-stack x)))
- (descriptor-reg
- (inst ,foprd (ea-for-df-desc x)))))
- (t
- ;; x to ST0
- (sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x))))
- ;; ST0 = ST0 op y
- (sc-case y
- (double-reg
- (inst ,fopd y))
- (double-stack
- (inst ,fopd (ea-for-df-stack y)))
- (descriptor-reg
- (inst ,fopd (ea-for-df-desc y))))))
-
- (note-next-instruction vop :internal-error)
-
- ;; Finally save the result.
- (sc-case r
- (double-reg
- (cond ((zerop (tn-offset r))
- (maybe-fp-wait node))
- (t
- (inst fst r))))
- (double-stack
- (inst fstd (ea-for-df-stack r))))))))
-
- #!+long-float
- (define-vop (,lname)
- (:translate ,op)
- (:args (x :scs (long-reg) :to :eval)
- (y :scs (long-reg) :to :eval))
- (:temporary (:sc long-reg :offset fr0-offset
- :from :eval :to :result) fr0)
- (:results (r :scs (long-reg)))
- (:arg-types long-float long-float)
- (:result-types long-float)
- (:policy :fast-safe)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator ,lcost
- ;; Handle a few special cases.
- (cond
- ;; x, y, and r are the same register.
- ((and (location= x r) (location= y r))
- (cond ((zerop (tn-offset r))
- (inst ,fop fr0))
- (t
- (inst fxch x)
- (inst ,fopd fr0)
- ;; XX the source register will not be valid.
- (note-next-instruction vop :internal-error)
- (inst fxch r))))
-
- ;; x and r are the same register.
- ((location= x r)
- (cond ((zerop (tn-offset r))
- ;; ST(0) = ST(0) op ST(y)
- (inst ,fopd y))
- (t
- ;; y to ST0
- (unless (zerop (tn-offset y))
- (copy-fp-reg-to-fr0 y))
- ;; ST(i) = ST(i) op ST0
- (inst ,fop-sti r)))
- (maybe-fp-wait node vop))
- ;; y and r are the same register.
- ((location= y r)
- (cond ((zerop (tn-offset r))
- ;; ST(0) = ST(x) op ST(0)
- (inst ,foprd x))
- (t
- ;; x to ST0
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x))
- ;; ST(i) = ST(0) op ST(i)
- (inst ,fopr-sti r)))
- (maybe-fp-wait node vop))
- ;; the default case
- (t
- ;; Get the result to ST0.
-
- ;; Special handling is needed if x or y are in ST0, and
- ;; simpler code is generated.
- (cond
- ;; x is in ST0.
- ((zerop (tn-offset x))
- ;; ST0 = ST0 op y
- (inst ,fopd y))
- ;; y is in ST0
- ((zerop (tn-offset y))
- ;; ST0 = x op ST0
- (inst ,foprd x))
- (t
- ;; x to ST0
- (copy-fp-reg-to-fr0 x)
- ;; ST0 = ST0 op y
- (inst ,fopd y)))
-
- (note-next-instruction vop :internal-error)
-
- ;; Finally save the result.
- (cond ((zerop (tn-offset r))
- (maybe-fp-wait node))
- (t
- (inst fst r))))))))))
+ (define-vop (,sname)
+ (:translate ,op)
+ (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
+ :to :eval)
+ (y :scs (single-reg single-stack #+nil descriptor-reg)
+ :to :eval))
+ (:temporary (:sc single-reg :offset fr0-offset
+ :from :eval :to :result) fr0)
+ (:results (r :scs (single-reg single-stack)))
+ (:arg-types single-float single-float)
+ (:result-types single-float)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator ,scost
+ ;; Handle a few special cases
+ (cond
+ ;; x, y, and r are the same register.
+ ((and (sc-is x single-reg) (location= x r) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (inst ,fop fr0))
+ (t
+ (inst fxch r)
+ (inst ,fop fr0)
+ ;; XX the source register will not be valid.
+ (note-next-instruction vop :internal-error)
+ (inst fxch r))))
+
+ ;; x and r are the same register.
+ ((and (sc-is x single-reg) (location= x r))
+ (cond ((zerop (tn-offset r))
+ (sc-case y
+ (single-reg
+ ;; ST(0) = ST(0) op ST(y)
+ (inst ,fop y))
+ (single-stack
+ ;; ST(0) = ST(0) op Mem
+ (inst ,fop (ea-for-sf-stack y)))
+ (descriptor-reg
+ (inst ,fop (ea-for-sf-desc y)))))
+ (t
+ ;; y to ST0
+ (sc-case y
+ (single-reg
+ (unless (zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 y)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is y single-stack)
+ (inst fld (ea-for-sf-stack y))
+ (inst fld (ea-for-sf-desc y)))))
+ ;; ST(i) = ST(i) op ST0
+ (inst ,fop-sti r)))
+ (maybe-fp-wait node vop))
+ ;; y and r are the same register.
+ ((and (sc-is y single-reg) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (sc-case x
+ (single-reg
+ ;; ST(0) = ST(x) op ST(0)
+ (inst ,fopr x))
+ (single-stack
+ ;; ST(0) = Mem op ST(0)
+ (inst ,fopr (ea-for-sf-stack x)))
+ (descriptor-reg
+ (inst ,fopr (ea-for-sf-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (single-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x single-stack)
+ (inst fld (ea-for-sf-stack x))
+ (inst fld (ea-for-sf-desc x)))))
+ ;; ST(i) = ST(0) op ST(i)
+ (inst ,fopr-sti r)))
+ (maybe-fp-wait node vop))
+ ;; the default case
+ (t
+ ;; Get the result to ST0.
+
+ ;; Special handling is needed if x or y are in ST0, and
+ ;; simpler code is generated.
+ (cond
+ ;; x is in ST0
+ ((and (sc-is x single-reg) (zerop (tn-offset x)))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (single-reg
+ (inst ,fop y))
+ (single-stack
+ (inst ,fop (ea-for-sf-stack y)))
+ (descriptor-reg
+ (inst ,fop (ea-for-sf-desc y)))))
+ ;; y is in ST0
+ ((and (sc-is y single-reg) (zerop (tn-offset y)))
+ ;; ST0 = x op ST0
+ (sc-case x
+ (single-reg
+ (inst ,fopr x))
+ (single-stack
+ (inst ,fopr (ea-for-sf-stack x)))
+ (descriptor-reg
+ (inst ,fopr (ea-for-sf-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (single-reg
+ (copy-fp-reg-to-fr0 x))
+ (single-stack
+ (inst fstp fr0)
+ (inst fld (ea-for-sf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fld (ea-for-sf-desc x))))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (single-reg
+ (inst ,fop y))
+ (single-stack
+ (inst ,fop (ea-for-sf-stack y)))
+ (descriptor-reg
+ (inst ,fop (ea-for-sf-desc y))))))
+
+ (note-next-instruction vop :internal-error)
+
+ ;; Finally save the result.
+ (sc-case r
+ (single-reg
+ (cond ((zerop (tn-offset r))
+ (maybe-fp-wait node))
+ (t
+ (inst fst r))))
+ (single-stack
+ (inst fst (ea-for-sf-stack r))))))))
+
+ (define-vop (,dname)
+ (:translate ,op)
+ (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
+ :to :eval)
+ (y :scs (double-reg double-stack #+nil descriptor-reg)
+ :to :eval))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :eval :to :result) fr0)
+ (:results (r :scs (double-reg double-stack)))
+ (:arg-types double-float double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator ,dcost
+ ;; Handle a few special cases.
+ (cond
+ ;; x, y, and r are the same register.
+ ((and (sc-is x double-reg) (location= x r) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (inst ,fop fr0))
+ (t
+ (inst fxch x)
+ (inst ,fopd fr0)
+ ;; XX the source register will not be valid.
+ (note-next-instruction vop :internal-error)
+ (inst fxch r))))
+
+ ;; x and r are the same register.
+ ((and (sc-is x double-reg) (location= x r))
+ (cond ((zerop (tn-offset r))
+ (sc-case y
+ (double-reg
+ ;; ST(0) = ST(0) op ST(y)
+ (inst ,fopd y))
+ (double-stack
+ ;; ST(0) = ST(0) op Mem
+ (inst ,fopd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst ,fopd (ea-for-df-desc y)))))
+ (t
+ ;; y to ST0
+ (sc-case y
+ (double-reg
+ (unless (zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 y)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is y double-stack)
+ (inst fldd (ea-for-df-stack y))
+ (inst fldd (ea-for-df-desc y)))))
+ ;; ST(i) = ST(i) op ST0
+ (inst ,fop-sti r)))
+ (maybe-fp-wait node vop))
+ ;; y and r are the same register.
+ ((and (sc-is y double-reg) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (sc-case x
+ (double-reg
+ ;; ST(0) = ST(x) op ST(0)
+ (inst ,foprd x))
+ (double-stack
+ ;; ST(0) = Mem op ST(0)
+ (inst ,foprd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst ,foprd (ea-for-df-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (double-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
+ ;; ST(i) = ST(0) op ST(i)
+ (inst ,fopr-sti r)))
+ (maybe-fp-wait node vop))
+ ;; the default case
+ (t
+ ;; Get the result to ST0.
+
+ ;; Special handling is needed if x or y are in ST0, and
+ ;; simpler code is generated.
+ (cond
+ ;; x is in ST0
+ ((and (sc-is x double-reg) (zerop (tn-offset x)))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (double-reg
+ (inst ,fopd y))
+ (double-stack
+ (inst ,fopd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst ,fopd (ea-for-df-desc y)))))
+ ;; y is in ST0
+ ((and (sc-is y double-reg) (zerop (tn-offset y)))
+ ;; ST0 = x op ST0
+ (sc-case x
+ (double-reg
+ (inst ,foprd x))
+ (double-stack
+ (inst ,foprd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst ,foprd (ea-for-df-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x))))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (double-reg
+ (inst ,fopd y))
+ (double-stack
+ (inst ,fopd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst ,fopd (ea-for-df-desc y))))))
+
+ (note-next-instruction vop :internal-error)
+
+ ;; Finally save the result.
+ (sc-case r
+ (double-reg
+ (cond ((zerop (tn-offset r))
+ (maybe-fp-wait node))
+ (t
+ (inst fst r))))
+ (double-stack
+ (inst fstd (ea-for-df-stack r))))))))
+
+ #!+long-float
+ (define-vop (,lname)
+ (:translate ,op)
+ (:args (x :scs (long-reg) :to :eval)
+ (y :scs (long-reg) :to :eval))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :eval :to :result) fr0)
+ (:results (r :scs (long-reg)))
+ (:arg-types long-float long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator ,lcost
+ ;; Handle a few special cases.
+ (cond
+ ;; x, y, and r are the same register.
+ ((and (location= x r) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (inst ,fop fr0))
+ (t
+ (inst fxch x)
+ (inst ,fopd fr0)
+ ;; XX the source register will not be valid.
+ (note-next-instruction vop :internal-error)
+ (inst fxch r))))
+
+ ;; x and r are the same register.
+ ((location= x r)
+ (cond ((zerop (tn-offset r))
+ ;; ST(0) = ST(0) op ST(y)
+ (inst ,fopd y))
+ (t
+ ;; y to ST0
+ (unless (zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 y))
+ ;; ST(i) = ST(i) op ST0
+ (inst ,fop-sti r)))
+ (maybe-fp-wait node vop))
+ ;; y and r are the same register.
+ ((location= y r)
+ (cond ((zerop (tn-offset r))
+ ;; ST(0) = ST(x) op ST(0)
+ (inst ,foprd x))
+ (t
+ ;; x to ST0
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x))
+ ;; ST(i) = ST(0) op ST(i)
+ (inst ,fopr-sti r)))
+ (maybe-fp-wait node vop))
+ ;; the default case
+ (t
+ ;; Get the result to ST0.
+
+ ;; Special handling is needed if x or y are in ST0, and
+ ;; simpler code is generated.
+ (cond
+ ;; x is in ST0.
+ ((zerop (tn-offset x))
+ ;; ST0 = ST0 op y
+ (inst ,fopd y))
+ ;; y is in ST0
+ ((zerop (tn-offset y))
+ ;; ST0 = x op ST0
+ (inst ,foprd x))
+ (t
+ ;; x to ST0
+ (copy-fp-reg-to-fr0 x)
+ ;; ST0 = ST0 op y
+ (inst ,fopd y)))
+
+ (note-next-instruction vop :internal-error)
+
+ ;; Finally save the result.
+ (cond ((zerop (tn-offset r))
+ (maybe-fp-wait node))
+ (t
+ (inst fst r))))))))))
(frob + fadd-sti fadd-sti
- fadd fadd +/single-float 2
- faddd faddd +/double-float 2
- +/long-float 2)
+ fadd fadd +/single-float 2
+ faddd faddd +/double-float 2
+ +/long-float 2)
(frob - fsub-sti fsubr-sti
- fsub fsubr -/single-float 2
- fsubd fsubrd -/double-float 2
- -/long-float 2)
+ fsub fsubr -/single-float 2
+ fsubd fsubrd -/double-float 2
+ -/long-float 2)
(frob * fmul-sti fmul-sti
- fmul fmul */single-float 3
- fmuld fmuld */double-float 3
- */long-float 3)
+ fmul fmul */single-float 3
+ fmuld fmuld */double-float 3
+ */long-float 3)
(frob / fdiv-sti fdivr-sti
- fdiv fdivr //single-float 12
- fdivd fdivrd //double-float 12
- //long-float 12))
+ fdiv fdivr //single-float 12
+ fdivd fdivrd //double-float 12
+ //long-float 12))
\f
(macrolet ((frob (name inst translate sc type)
- `(define-vop (,name)
- (:args (x :scs (,sc) :target fr0))
- (:results (y :scs (,sc)))
- (:translate ,translate)
- (:policy :fast-safe)
- (:arg-types ,type)
- (:result-types ,type)
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:ignore fr0)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 1
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; Maybe save it.
- (inst ,inst) ; Clobber st0.
- (unless (zerop (tn-offset y))
- (inst fst y))))))
+ `(define-vop (,name)
+ (:args (x :scs (,sc) :target fr0))
+ (:results (y :scs (,sc)))
+ (:translate ,translate)
+ (:policy :fast-safe)
+ (:arg-types ,type)
+ (:result-types ,type)
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:ignore fr0)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; Maybe save it.
+ (inst ,inst) ; Clobber st0.
+ (unless (zerop (tn-offset y))
+ (inst fst y))))))
(frob abs/single-float fabs abs single-reg single-float)
(frob abs/double-float fabs abs double-reg double-float)
(inst fxch x)
(inst fucom y)
(inst fxch x)))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x40)
(inst jmp (if not-p :ne :e) target)))
(define-vop (=/single-float =/float)
(:translate =)
(:args (x :scs (single-reg))
- (y :scs (single-reg)))
+ (y :scs (single-reg)))
(:arg-types single-float single-float))
(define-vop (=/double-float =/float)
(:translate =)
(:args (x :scs (double-reg))
- (y :scs (double-reg)))
+ (y :scs (double-reg)))
(:arg-types double-float double-float))
#!+long-float
(define-vop (=/long-float =/float)
(:translate =)
(:args (x :scs (long-reg))
- (y :scs (long-reg)))
+ (y :scs (long-reg)))
(:arg-types long-float long-float))
(define-vop (<single-float)
(:translate <)
(:args (x :scs (single-reg single-stack descriptor-reg))
- (y :scs (single-reg single-stack descriptor-reg)))
+ (y :scs (single-reg single-stack descriptor-reg)))
(:arg-types single-float single-float)
(:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
;; y is ST0.
((and (sc-is y single-reg) (zerop (tn-offset y)))
(sc-case x
- (single-reg
- (inst fcom x))
- ((single-stack descriptor-reg)
- (if (sc-is x single-stack)
- (inst fcom (ea-for-sf-stack x))
- (inst fcom (ea-for-sf-desc x)))))
- (inst fnstsw) ; status word to ax
+ (single-reg
+ (inst fcom x))
+ ((single-stack descriptor-reg)
+ (if (sc-is x single-stack)
+ (inst fcom (ea-for-sf-stack x))
+ (inst fcom (ea-for-sf-desc x)))))
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45))
;; general case when y is not in ST0
(t
;; x to ST0
(sc-case x
- (single-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x single-stack)
- (inst fld (ea-for-sf-stack x))
- (inst fld (ea-for-sf-desc x)))))
+ (single-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x single-stack)
+ (inst fld (ea-for-sf-stack x))
+ (inst fld (ea-for-sf-desc x)))))
(sc-case y
- (single-reg
- (inst fcom y))
- ((single-stack descriptor-reg)
- (if (sc-is y single-stack)
- (inst fcom (ea-for-sf-stack y))
- (inst fcom (ea-for-sf-desc y)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
+ (single-reg
+ (inst fcom y))
+ ((single-stack descriptor-reg)
+ (if (sc-is y single-stack)
+ (inst fcom (ea-for-sf-stack y))
+ (inst fcom (ea-for-sf-desc y)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x01)))
(inst jmp (if not-p :ne :e) target)))
(define-vop (<double-float)
(:translate <)
(:args (x :scs (double-reg double-stack descriptor-reg))
- (y :scs (double-reg double-stack descriptor-reg)))
+ (y :scs (double-reg double-stack descriptor-reg)))
(:arg-types double-float double-float)
(:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
;; y is ST0.
((and (sc-is y double-reg) (zerop (tn-offset y)))
(sc-case x
- (double-reg
- (inst fcomd x))
- ((double-stack descriptor-reg)
- (if (sc-is x double-stack)
- (inst fcomd (ea-for-df-stack x))
- (inst fcomd (ea-for-df-desc x)))))
- (inst fnstsw) ; status word to ax
+ (double-reg
+ (inst fcomd x))
+ ((double-stack descriptor-reg)
+ (if (sc-is x double-stack)
+ (inst fcomd (ea-for-df-stack x))
+ (inst fcomd (ea-for-df-desc x)))))
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45))
;; General case when y is not in ST0.
(t
;; x to ST0
(sc-case x
- (double-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
+ (double-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
(sc-case y
- (double-reg
- (inst fcomd y))
- ((double-stack descriptor-reg)
- (if (sc-is y double-stack)
- (inst fcomd (ea-for-df-stack y))
- (inst fcomd (ea-for-df-desc y)))))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
+ (double-reg
+ (inst fcomd y))
+ ((double-stack descriptor-reg)
+ (if (sc-is y double-stack)
+ (inst fcomd (ea-for-df-stack y))
+ (inst fcomd (ea-for-df-desc y)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x01)))
(inst jmp (if not-p :ne :e) target)))
(define-vop (<long-float)
(:translate <)
(:args (x :scs (long-reg))
- (y :scs (long-reg)))
+ (y :scs (long-reg)))
(:arg-types long-float long-float)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
(:conditional)
;; x is in ST0; y is in any reg.
((zerop (tn-offset x))
(inst fcomd y)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x01))
;; y is in ST0; x is in another reg.
((zerop (tn-offset y))
(inst fcomd x)
- (inst fnstsw) ; status word to ax
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45))
;; x and y are the same register, not ST0
;; x and y are different registers, neither ST0.
(inst fxch y)
(inst fcomd x)
(inst fxch y)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45))) ; C3 C2 C0
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45))) ; C3 C2 C0
(inst jmp (if not-p :ne :e) target)))
(define-vop (>single-float)
(:translate >)
(:args (x :scs (single-reg single-stack descriptor-reg))
- (y :scs (single-reg single-stack descriptor-reg)))
+ (y :scs (single-reg single-stack descriptor-reg)))
(:arg-types single-float single-float)
(:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
;; y is ST0.
((and (sc-is y single-reg) (zerop (tn-offset y)))
(sc-case x
- (single-reg
- (inst fcom x))
- ((single-stack descriptor-reg)
- (if (sc-is x single-stack)
- (inst fcom (ea-for-sf-stack x))
- (inst fcom (ea-for-sf-desc x)))))
- (inst fnstsw) ; status word to ax
+ (single-reg
+ (inst fcom x))
+ ((single-stack descriptor-reg)
+ (if (sc-is x single-stack)
+ (inst fcom (ea-for-sf-stack x))
+ (inst fcom (ea-for-sf-desc x)))))
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45)
(inst cmp ah-tn #x01))
(t
;; x to ST0
(sc-case x
- (single-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((single-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x single-stack)
- (inst fld (ea-for-sf-stack x))
- (inst fld (ea-for-sf-desc x)))))
+ (single-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x single-stack)
+ (inst fld (ea-for-sf-stack x))
+ (inst fld (ea-for-sf-desc x)))))
(sc-case y
- (single-reg
- (inst fcom y))
- ((single-stack descriptor-reg)
- (if (sc-is y single-stack)
- (inst fcom (ea-for-sf-stack y))
- (inst fcom (ea-for-sf-desc y)))))
- (inst fnstsw) ; status word to ax
+ (single-reg
+ (inst fcom y))
+ ((single-stack descriptor-reg)
+ (if (sc-is y single-stack)
+ (inst fcom (ea-for-sf-stack y))
+ (inst fcom (ea-for-sf-desc y)))))
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45)))
(inst jmp (if not-p :ne :e) target)))
(define-vop (>double-float)
(:translate >)
(:args (x :scs (double-reg double-stack descriptor-reg))
- (y :scs (double-reg double-stack descriptor-reg)))
+ (y :scs (double-reg double-stack descriptor-reg)))
(:arg-types double-float double-float)
(:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
;; y is ST0.
((and (sc-is y double-reg) (zerop (tn-offset y)))
(sc-case x
- (double-reg
- (inst fcomd x))
- ((double-stack descriptor-reg)
- (if (sc-is x double-stack)
- (inst fcomd (ea-for-df-stack x))
- (inst fcomd (ea-for-df-desc x)))))
- (inst fnstsw) ; status word to ax
+ (double-reg
+ (inst fcomd x))
+ ((double-stack descriptor-reg)
+ (if (sc-is x double-stack)
+ (inst fcomd (ea-for-df-stack x))
+ (inst fcomd (ea-for-df-desc x)))))
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45)
(inst cmp ah-tn #x01))
(t
;; x to ST0
(sc-case x
- (double-reg
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x)))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
+ (double-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
(sc-case y
- (double-reg
- (inst fcomd y))
- ((double-stack descriptor-reg)
- (if (sc-is y double-stack)
- (inst fcomd (ea-for-df-stack y))
- (inst fcomd (ea-for-df-desc y)))))
- (inst fnstsw) ; status word to ax
+ (double-reg
+ (inst fcomd y))
+ ((double-stack descriptor-reg)
+ (if (sc-is y double-stack)
+ (inst fcomd (ea-for-df-stack y))
+ (inst fcomd (ea-for-df-desc y)))))
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45)))
(inst jmp (if not-p :ne :e) target)))
(define-vop (>long-float)
(:translate >)
(:args (x :scs (long-reg))
- (y :scs (long-reg)))
+ (y :scs (long-reg)))
(:arg-types long-float long-float)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
(:conditional)
;; y is in ST0; x is in any reg.
((zerop (tn-offset y))
(inst fcomd x)
- (inst fnstsw) ; status word to ax
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45)
(inst cmp ah-tn #x01))
;; x is in ST0; y is in another reg.
((zerop (tn-offset x))
(inst fcomd y)
- (inst fnstsw) ; status word to ax
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45))
;; y and x are the same register, not ST0
;; y and x are different registers, neither ST0.
(inst fxch x)
(inst fcomd y)
(inst fxch x)
- (inst fnstsw) ; status word to ax
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45)))
(inst jmp (if not-p :ne :e) target)))
(inst fxch x)
(inst ftst)
(inst fxch x)))
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x45) ; C3 C2 C0
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
(unless (zerop code)
- (inst cmp ah-tn code))
+ (inst cmp ah-tn code))
(inst jmp (if not-p :ne :e) target)))
(define-vop (=0/single-float float-test)
#!+long-float
(deftransform eql ((x y) (long-float long-float))
`(and (= (long-float-low-bits x) (long-float-low-bits y))
- (= (long-float-high-bits x) (long-float-high-bits y))
- (= (long-float-exp-bits x) (long-float-exp-bits y))))
+ (= (long-float-high-bits x) (long-float-high-bits y))
+ (= (long-float-exp-bits x) (long-float-exp-bits y))))
\f
;;;; conversion
(macrolet ((frob (name translate to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (signed-stack signed-reg) :target temp))
- (:temporary (:sc signed-stack) temp)
- (:results (y :scs (,to-sc)))
- (:arg-types signed-num)
- (:result-types ,to-type)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- (sc-case x
- (signed-reg
- (inst mov temp x)
- (with-empty-tn@fp-top(y)
- (note-this-location vop :internal-error)
- (inst fild temp)))
- (signed-stack
- (with-empty-tn@fp-top(y)
- (note-this-location vop :internal-error)
- (inst fild x))))))))
+ `(define-vop (,name)
+ (:args (x :scs (signed-stack signed-reg) :target temp))
+ (:temporary (:sc signed-stack) temp)
+ (:results (y :scs (,to-sc)))
+ (:arg-types signed-num)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (sc-case x
+ (signed-reg
+ (inst mov temp x)
+ (with-empty-tn@fp-top(y)
+ (note-this-location vop :internal-error)
+ (inst fild temp)))
+ (signed-stack
+ (with-empty-tn@fp-top(y)
+ (note-this-location vop :internal-error)
+ (inst fild x))))))))
(frob %single-float/signed %single-float single-reg single-float)
(frob %double-float/signed %double-float double-reg double-float)
#!+long-float
(frob %long-float/signed %long-float long-reg long-float))
(macrolet ((frob (name translate to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (unsigned-reg)))
- (:results (y :scs (,to-sc)))
- (:arg-types unsigned-num)
- (:result-types ,to-type)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 6
- (inst push 0)
- (inst push x)
- (with-empty-tn@fp-top(y)
- (note-this-location vop :internal-error)
- (inst fildl (make-ea :dword :base esp-tn)))
- (inst add esp-tn 8)))))
+ `(define-vop (,name)
+ (:args (x :scs (unsigned-reg)))
+ (:results (y :scs (,to-sc)))
+ (:arg-types unsigned-num)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 6
+ (inst push 0)
+ (inst push x)
+ (with-empty-tn@fp-top(y)
+ (note-this-location vop :internal-error)
+ (inst fildl (make-ea :dword :base esp-tn)))
+ (inst add esp-tn 8)))))
(frob %single-float/unsigned %single-float single-reg single-float)
(frob %double-float/unsigned %double-float double-reg double-float)
#!+long-float
;;; These should be no-ops but the compiler might want to move some
;;; things around.
(macrolet ((frob (name translate from-sc from-type to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (,from-sc) :target y))
- (:results (y :scs (,to-sc)))
- (:arg-types ,from-type)
- (:result-types ,to-type)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 2
- (note-this-location vop :internal-error)
- (unless (location= x y)
- (cond
- ((zerop (tn-offset x))
- ;; x is in ST0, y is in another reg. not ST0
- (inst fst y))
- ((zerop (tn-offset y))
- ;; y is in ST0, x is in another reg. not ST0
- (copy-fp-reg-to-fr0 x))
- (t
- ;; Neither x or y are in ST0, and they are not in
- ;; the same reg.
- (inst fxch x)
- (inst fst y)
- (inst fxch x))))))))
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc) :target y))
+ (:results (y :scs (,to-sc)))
+ (:arg-types ,from-type)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 2
+ (note-this-location vop :internal-error)
+ (unless (location= x y)
+ (cond
+ ((zerop (tn-offset x))
+ ;; x is in ST0, y is in another reg. not ST0
+ (inst fst y))
+ ((zerop (tn-offset y))
+ ;; y is in ST0, x is in another reg. not ST0
+ (copy-fp-reg-to-fr0 x))
+ (t
+ ;; Neither x or y are in ST0, and they are not in
+ ;; the same reg.
+ (inst fxch x)
+ (inst fst y)
+ (inst fxch x))))))))
(frob %single-float/double-float %single-float double-reg
- double-float single-reg single-float)
+ double-float single-reg single-float)
#!+long-float
(frob %single-float/long-float %single-float long-reg
- long-float single-reg single-float)
+ long-float single-reg single-float)
(frob %double-float/single-float %double-float single-reg single-float
- double-reg double-float)
+ double-reg double-float)
#!+long-float
(frob %double-float/long-float %double-float long-reg long-float
- double-reg double-float)
+ double-reg double-float)
#!+long-float
(frob %long-float/single-float %long-float single-reg single-float
- long-reg long-float)
+ long-reg long-float)
#!+long-float
(frob %long-float/double-float %long-float double-reg double-float
- long-reg long-float))
+ long-reg long-float))
(macrolet ((frob (trans from-sc from-type round-p)
- `(define-vop (,(symbolicate trans "/" from-type))
- (:args (x :scs (,from-sc)))
- (:temporary (:sc signed-stack) stack-temp)
- ,@(unless round-p
- '((:temporary (:sc unsigned-stack) scw)
- (:temporary (:sc any-reg) rcw)))
- (:results (y :scs (signed-reg)))
- (:arg-types ,from-type)
- (:result-types signed-num)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline float truncate")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- ,@(unless round-p
- '((note-this-location vop :internal-error)
- ;; Catch any pending FPE exceptions.
- (inst wait)))
- (,(if round-p 'progn 'pseudo-atomic)
- ;; Normal mode (for now) is "round to best".
- (with-tn@fp-top (x)
- ,@(unless round-p
- '((inst fnstcw scw) ; save current control word
- (move rcw scw) ; into 16-bit register
- (inst or rcw (ash #b11 10)) ; CHOP
- (move stack-temp rcw)
- (inst fldcw stack-temp)))
- (sc-case y
- (signed-stack
- (inst fist y))
- (signed-reg
- (inst fist stack-temp)
- (inst mov y stack-temp)))
- ,@(unless round-p
- '((inst fldcw scw)))))))))
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc)))
+ (:temporary (:sc signed-stack) stack-temp)
+ ,@(unless round-p
+ '((:temporary (:sc unsigned-stack) scw)
+ (:temporary (:sc any-reg) rcw)))
+ (:results (y :scs (signed-reg)))
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ ,@(unless round-p
+ '((note-this-location vop :internal-error)
+ ;; Catch any pending FPE exceptions.
+ (inst wait)))
+ (,(if round-p 'progn 'pseudo-atomic)
+ ;; Normal mode (for now) is "round to best".
+ (with-tn@fp-top (x)
+ ,@(unless round-p
+ '((inst fnstcw scw) ; save current control word
+ (move rcw scw) ; into 16-bit register
+ (inst or rcw (ash #b11 10)) ; CHOP
+ (move stack-temp rcw)
+ (inst fldcw stack-temp)))
+ (sc-case y
+ (signed-stack
+ (inst fist y))
+ (signed-reg
+ (inst fist stack-temp)
+ (inst mov y stack-temp)))
+ ,@(unless round-p
+ '((inst fldcw scw)))))))))
(frob %unary-truncate single-reg single-float nil)
(frob %unary-truncate double-reg double-float nil)
#!+long-float
(frob %unary-round long-reg long-float t))
(macrolet ((frob (trans from-sc from-type round-p)
- `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
- (:args (x :scs (,from-sc) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- ,@(unless round-p
- '((:temporary (:sc unsigned-stack) stack-temp)
- (:temporary (:sc unsigned-stack) scw)
- (:temporary (:sc any-reg) rcw)))
- (:results (y :scs (unsigned-reg)))
- (:arg-types ,from-type)
- (:result-types unsigned-num)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline float truncate")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 5
- ,@(unless round-p
- '((note-this-location vop :internal-error)
- ;; Catch any pending FPE exceptions.
- (inst wait)))
- ;; Normal mode (for now) is "round to best".
- (unless (zerop (tn-offset x))
- (copy-fp-reg-to-fr0 x))
- ,@(unless round-p
- '((inst fnstcw scw) ; save current control word
- (move rcw scw) ; into 16-bit register
- (inst or rcw (ash #b11 10)) ; CHOP
- (move stack-temp rcw)
- (inst fldcw stack-temp)))
- (inst sub esp-tn 8)
- (inst fistpl (make-ea :dword :base esp-tn))
- (inst pop y)
- (inst fld fr0) ; copy fr0 to at least restore stack.
- (inst add esp-tn 4)
- ,@(unless round-p
- '((inst fldcw scw)))))))
+ `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
+ (:args (x :scs (,from-sc) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ ,@(unless round-p
+ '((:temporary (:sc unsigned-stack) stack-temp)
+ (:temporary (:sc unsigned-stack) scw)
+ (:temporary (:sc any-reg) rcw)))
+ (:results (y :scs (unsigned-reg)))
+ (:arg-types ,from-type)
+ (:result-types unsigned-num)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ ,@(unless round-p
+ '((note-this-location vop :internal-error)
+ ;; Catch any pending FPE exceptions.
+ (inst wait)))
+ ;; Normal mode (for now) is "round to best".
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x))
+ ,@(unless round-p
+ '((inst fnstcw scw) ; save current control word
+ (move rcw scw) ; into 16-bit register
+ (inst or rcw (ash #b11 10)) ; CHOP
+ (move stack-temp rcw)
+ (inst fldcw stack-temp)))
+ (inst sub esp-tn 8)
+ (inst fistpl (make-ea :dword :base esp-tn))
+ (inst pop y)
+ (inst fld fr0) ; copy fr0 to at least restore stack.
+ (inst add esp-tn 4)
+ ,@(unless round-p
+ '((inst fldcw scw)))))))
(frob %unary-truncate single-reg single-float nil)
(frob %unary-truncate double-reg double-float nil)
#!+long-float
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
- :load-if (not (or (and (sc-is bits signed-stack)
- (sc-is res single-reg))
- (and (sc-is bits signed-stack)
- (sc-is res single-stack)
- (location= bits res))))))
+ :load-if (not (or (and (sc-is bits signed-stack)
+ (sc-is res single-reg))
+ (and (sc-is bits signed-stack)
+ (sc-is res single-stack)
+ (location= bits res))))))
(:results (res :scs (single-reg single-stack)))
(:temporary (:sc signed-stack) stack-temp)
(:arg-types signed-num)
(:generator 4
(sc-case res
(single-stack
- (sc-case bits
- (signed-reg
- (inst mov res bits))
- (signed-stack
- (aver (location= bits res)))))
+ (sc-case bits
+ (signed-reg
+ (inst mov res bits))
+ (signed-stack
+ (aver (location= bits res)))))
(single-reg
- (sc-case bits
- (signed-reg
- ;; source must be in memory
- (inst mov stack-temp bits)
- (with-empty-tn@fp-top(res)
- (inst fld stack-temp)))
- (signed-stack
- (with-empty-tn@fp-top(res)
- (inst fld bits))))))))
+ (sc-case bits
+ (signed-reg
+ ;; source must be in memory
+ (inst mov stack-temp bits)
+ (with-empty-tn@fp-top(res)
+ (inst fld stack-temp)))
+ (signed-stack
+ (with-empty-tn@fp-top(res)
+ (inst fld bits))))))))
(define-vop (make-double-float)
(:args (hi-bits :scs (signed-reg))
- (lo-bits :scs (unsigned-reg)))
+ (lo-bits :scs (unsigned-reg)))
(:results (res :scs (double-reg)))
(:temporary (:sc double-stack) temp)
(:arg-types signed-num unsigned-num)
(storew hi-bits ebp-tn (- offset))
(storew lo-bits ebp-tn (- (1+ offset)))
(with-empty-tn@fp-top(res)
- (inst fldd (make-ea :dword :base ebp-tn
- :disp (- (* (1+ offset) n-word-bytes))))))))
+ (inst fldd (make-ea :dword :base ebp-tn
+ :disp (- (* (1+ offset) n-word-bytes))))))))
#!+long-float
(define-vop (make-long-float)
(:args (exp-bits :scs (signed-reg))
- (hi-bits :scs (unsigned-reg))
- (lo-bits :scs (unsigned-reg)))
+ (hi-bits :scs (unsigned-reg))
+ (lo-bits :scs (unsigned-reg)))
(:results (res :scs (long-reg)))
(:temporary (:sc long-stack) temp)
(:arg-types signed-num unsigned-num unsigned-num)
(storew hi-bits ebp-tn (- (1+ offset)))
(storew lo-bits ebp-tn (- (+ offset 2)))
(with-empty-tn@fp-top(res)
- (inst fldl (make-ea :dword :base ebp-tn
- :disp (- (* (+ offset 2) n-word-bytes))))))))
+ (inst fldl (make-ea :dword :base ebp-tn
+ :disp (- (* (+ offset 2) n-word-bytes))))))))
(define-vop (single-float-bits)
(:args (float :scs (single-reg descriptor-reg)
- :load-if (not (sc-is float single-stack))))
+ :load-if (not (sc-is float single-stack))))
(:results (bits :scs (signed-reg)))
(:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
(:arg-types single-float)
(sc-case bits
(signed-reg
(sc-case float
- (single-reg
- (with-tn@fp-top(float)
- (inst fst stack-temp)
- (inst mov bits stack-temp)))
- (single-stack
- (inst mov bits float))
- (descriptor-reg
- (loadw
- bits float single-float-value-slot
- other-pointer-lowtag))))
+ (single-reg
+ (with-tn@fp-top(float)
+ (inst fst stack-temp)
+ (inst mov bits stack-temp)))
+ (single-stack
+ (inst mov bits float))
+ (descriptor-reg
+ (loadw
+ bits float single-float-value-slot
+ other-pointer-lowtag))))
(signed-stack
(sc-case float
- (single-reg
- (with-tn@fp-top(float)
- (inst fst bits))))))))
+ (single-reg
+ (with-tn@fp-top(float)
+ (inst fst bits))))))))
(define-vop (double-float-high-bits)
(:args (float :scs (double-reg descriptor-reg)
- :load-if (not (sc-is float double-stack))))
+ :load-if (not (sc-is float double-stack))))
(:results (hi-bits :scs (signed-reg)))
(:temporary (:sc double-stack) temp)
(:arg-types double-float)
(:generator 5
(sc-case float
(double-reg
- (with-tn@fp-top(float)
- (let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 2 (tn-offset temp))
- n-word-bytes)))))
- (inst fstd where)))
- (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 2 (tn-offset temp))
+ n-word-bytes)))))
+ (inst fstd where)))
+ (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
(double-stack
- (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
+ (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
(descriptor-reg
- (loadw hi-bits float (1+ double-float-value-slot)
- other-pointer-lowtag)))))
+ (loadw hi-bits float (1+ double-float-value-slot)
+ other-pointer-lowtag)))))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg descriptor-reg)
- :load-if (not (sc-is float double-stack))))
+ :load-if (not (sc-is float double-stack))))
(:results (lo-bits :scs (unsigned-reg)))
(:temporary (:sc double-stack) temp)
(:arg-types double-float)
(:generator 5
(sc-case float
(double-reg
- (with-tn@fp-top(float)
- (let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 2 (tn-offset temp))
- n-word-bytes)))))
- (inst fstd where)))
- (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 2 (tn-offset temp))
+ n-word-bytes)))))
+ (inst fstd where)))
+ (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
(double-stack
- (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
+ (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
(descriptor-reg
- (loadw lo-bits float double-float-value-slot
- other-pointer-lowtag)))))
+ (loadw lo-bits float double-float-value-slot
+ other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-exp-bits)
(:args (float :scs (long-reg descriptor-reg)
- :load-if (not (sc-is float long-stack))))
+ :load-if (not (sc-is float long-stack))))
(:results (exp-bits :scs (signed-reg)))
(:temporary (:sc long-stack) temp)
(:arg-types long-float)
(:generator 5
(sc-case float
(long-reg
- (with-tn@fp-top(float)
- (let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 3 (tn-offset temp))
- n-word-bytes)))))
- (store-long-float where)))
- (inst movsx exp-bits
- (make-ea :word :base ebp-tn
- :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 3 (tn-offset temp))
+ n-word-bytes)))))
+ (store-long-float where)))
+ (inst movsx exp-bits
+ (make-ea :word :base ebp-tn
+ :disp (* (- (1+ (tn-offset temp))) n-word-bytes))))
(long-stack
- (inst movsx exp-bits
- (make-ea :word :base ebp-tn
- :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
+ (inst movsx exp-bits
+ (make-ea :word :base ebp-tn
+ :disp (* (- (1+ (tn-offset float))) n-word-bytes))))
(descriptor-reg
- (inst movsx exp-bits
- (make-ea :word :base float
- :disp (- (* (+ 2 long-float-value-slot)
- n-word-bytes)
- other-pointer-lowtag)))))))
+ (inst movsx exp-bits
+ (make-ea :word :base float
+ :disp (- (* (+ 2 long-float-value-slot)
+ n-word-bytes)
+ other-pointer-lowtag)))))))
#!+long-float
(define-vop (long-float-high-bits)
(:args (float :scs (long-reg descriptor-reg)
- :load-if (not (sc-is float long-stack))))
+ :load-if (not (sc-is float long-stack))))
(:results (hi-bits :scs (unsigned-reg)))
(:temporary (:sc long-stack) temp)
(:arg-types long-float)
(:generator 5
(sc-case float
(long-reg
- (with-tn@fp-top(float)
- (let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 3 (tn-offset temp))
- n-word-bytes)))))
- (store-long-float where)))
- (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 3 (tn-offset temp))
+ n-word-bytes)))))
+ (store-long-float where)))
+ (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
(long-stack
- (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
+ (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
(descriptor-reg
- (loadw hi-bits float (1+ long-float-value-slot)
- other-pointer-lowtag)))))
+ (loadw hi-bits float (1+ long-float-value-slot)
+ other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-low-bits)
(:args (float :scs (long-reg descriptor-reg)
- :load-if (not (sc-is float long-stack))))
+ :load-if (not (sc-is float long-stack))))
(:results (lo-bits :scs (unsigned-reg)))
(:temporary (:sc long-stack) temp)
(:arg-types long-float)
(:generator 5
(sc-case float
(long-reg
- (with-tn@fp-top(float)
- (let ((where (make-ea :dword :base ebp-tn
- :disp (- (* (+ 3 (tn-offset temp))
- n-word-bytes)))))
- (store-long-float where)))
- (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 3 (tn-offset temp))
+ n-word-bytes)))))
+ (store-long-float where)))
+ (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
(long-stack
- (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
+ (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
(descriptor-reg
- (loadw lo-bits float long-float-value-slot
- other-pointer-lowtag)))))
+ (loadw lo-bits float long-float-value-slot
+ other-pointer-lowtag)))))
\f
;;;; float mode hackery
(:translate floating-point-modes)
(:policy :fast-safe)
(:temporary (:sc unsigned-reg :offset eax-offset :target res
- :to :result) eax)
+ :to :result) eax)
(:generator 8
- (inst sub esp-tn npx-env-size) ; Make space on stack.
- (inst wait) ; Catch any pending FPE exceptions
+ (inst sub esp-tn npx-env-size) ; Make space on stack.
+ (inst wait) ; Catch any pending FPE exceptions
(inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
(inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state.
;; Move current status to high word.
(inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
;; Move exception mask to low word.
(inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
- (inst add esp-tn npx-env-size) ; Pop stack.
- (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
+ (inst add esp-tn npx-env-size) ; Pop stack.
+ (inst xor eax #x3f) ; Flip exception mask to trap enable bits.
(move res eax)))
(define-vop (set-floating-point-modes)
(:translate (setf floating-point-modes))
(:policy :fast-safe)
(:temporary (:sc unsigned-reg :offset eax-offset
- :from :eval :to :result) eax)
+ :from :eval :to :result) eax)
(:generator 3
- (inst sub esp-tn npx-env-size) ; Make space on stack.
- (inst wait) ; Catch any pending FPE exceptions.
+ (inst sub esp-tn npx-env-size) ; Make space on stack.
+ (inst wait) ; Catch any pending FPE exceptions.
(inst fstenv (make-ea :dword :base esp-tn))
(inst mov eax new)
- (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
+ (inst xor eax #x3f) ; Turn trap enable bits into exception mask.
(inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
- (inst shr eax 16) ; position status word
+ (inst shr eax 16) ; position status word
(inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
(inst fldenv (make-ea :dword :base esp-tn))
- (inst add esp-tn npx-env-size) ; Pop stack.
+ (inst add esp-tn npx-env-size) ; Pop stack.
(move res new)))
\f
#!-long-float
;;; to remove the inlined alien routine def.
(macrolet ((frob (func trans op)
- `(define-vop (,func)
- (:args (x :scs (double-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:ignore fr0)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline NPX function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,op) ; clobber st0
- (cond ((zerop (tn-offset y))
- (maybe-fp-wait node))
- (t
- (inst fst y)))))))
+ `(define-vop (,func)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:ignore fr0)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline NPX function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op) ; clobber st0
+ (cond ((zerop (tn-offset y))
+ (maybe-fp-wait node))
+ (t
+ (inst fst y)))))))
;; Quick versions of fsin and fcos that require the argument to be
;; within range 2^63.
(:translate %tan-quick)
(:args (x :scs (double-reg) :target fr0))
(:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (double-reg)))
(:arg-types double-float)
(:result-types double-float)
(note-this-location vop :internal-error)
(case (tn-offset x)
(0
- (inst fstp fr1))
+ (inst fstp fr1))
(1
- (inst fstp fr0))
+ (inst fstp fr0))
(t
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2)))))
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
(inst fptan)
;; Result is in fr1
(case (tn-offset y)
(0
- (inst fxch fr1))
+ (inst fxch fr1))
(1)
(t
- (inst fxch fr1)
- (inst fstd y)))))
+ (inst fxch fr1)
+ (inst fstd y)))))
;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0
;;; result if the argument is out of range 2^63 and would thus be
;;; hopelessly inaccurate.
(macrolet ((frob (func trans op)
- `(define-vop (,func)
- (:translate ,trans)
- (:args (x :scs (double-reg) :target fr0))
- (:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc unsigned-reg :offset eax-offset
- :from :argument :to :result) eax)
- (:results (y :scs (double-reg)))
- (:arg-types double-float)
- (:result-types double-float)
- (:policy :fast-safe)
- (:note "inline sin/cos function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:ignore eax)
- (:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,op)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
- (inst jmp :z DONE)
- ;; Else x was out of range so reduce it; ST0 is unchanged.
- (inst fstp fr0) ; Load 0.0
- (inst fldz)
- DONE
- (unless (zerop (tn-offset y))
- (inst fstd y))))))
- (frob fsin %sin fsin)
- (frob fcos %cos fcos))
+ `(define-vop (,func)
+ (:translate ,trans)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :argument :to :result) eax)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline sin/cos function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fstp fr0) ; Load 0.0
+ (inst fldz)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))))
+ (frob fsin %sin fsin)
+ (frob fcos %cos fcos))
(define-vop (ftan)
(:translate %tan)
(:args (x :scs (double-reg) :target fr0))
(:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:temporary (:sc unsigned-reg :offset eax-offset
- :from :argument :to :result) eax)
+ :from :argument :to :result) eax)
(:results (y :scs (double-reg)))
(:arg-types double-float)
(:result-types double-float)
(note-this-location vop :internal-error)
(case (tn-offset x)
(0
- (inst fstp fr1))
+ (inst fstp fr1))
(1
- (inst fstp fr0))
+ (inst fstp fr0))
(t
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2)))))
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
(inst fptan)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
(inst jmp :z DONE)
;; Else x was out of range so load 0.0
(inst fxch fr1)
;; Result is in fr1
(case (tn-offset y)
(0
- (inst fxch fr1))
+ (inst fxch fr1))
(1)
(t
- (inst fxch fr1)
- (inst fstd y)))))
+ (inst fxch fr1)
+ (inst fstd y)))))
;;; %exp that handles the following special cases: exp(+Inf) is +Inf;
;;; exp(-Inf) is 0; exp(NaN) is NaN.
(:args (x :scs (double-reg) :target fr0))
(:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
(:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:temporary (:sc double-reg :offset fr2-offset
- :from :argument :to :result) fr2)
+ :from :argument :to :result) fr2)
(:results (y :scs (double-reg)))
(:arg-types double-float)
(:result-types double-float)
(:generator 5
(note-this-location vop :internal-error)
(unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
+ (inst fxch x) ; x to top of stack
(unless (location= x y)
- (inst fst x))) ; maybe save it
+ (inst fst x))) ; maybe save it
;; Check for Inf or NaN
(inst fxam)
(inst fnstsw)
(inst sahf)
- (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
- (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
- (inst and ah-tn #x02) ; Test sign of Inf.
- (inst jmp :z DONE) ; +Inf gives +Inf.
- (inst fstp fr0) ; -Inf gives 0
+ (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
+ (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
+ (inst and ah-tn #x02) ; Test sign of Inf.
+ (inst jmp :z DONE) ; +Inf gives +Inf.
+ (inst fstp fr0) ; -Inf gives 0
(inst fldz)
(inst jmp-short DONE)
NOINFNAN
(inst fld fr0)
DONE
(unless (zerop (tn-offset y))
- (inst fstd y))))
+ (inst fstd y))))
;;; Expm1 = exp(x) - 1.
;;; Handles the following special cases:
(:args (x :scs (double-reg) :target fr0))
(:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
(:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:temporary (:sc double-reg :offset fr2-offset
- :from :argument :to :result) fr2)
+ :from :argument :to :result) fr2)
(:results (y :scs (double-reg)))
(:arg-types double-float)
(:result-types double-float)
(:generator 5
(note-this-location vop :internal-error)
(unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
+ (inst fxch x) ; x to top of stack
(unless (location= x y)
- (inst fst x))) ; maybe save it
+ (inst fst x))) ; maybe save it
;; Check for Inf or NaN
(inst fxam)
(inst fnstsw)
(inst sahf)
- (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
- (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
- (inst and ah-tn #x02) ; Test sign of Inf.
- (inst jmp :z DONE) ; +Inf gives +Inf.
- (inst fstp fr0) ; -Inf gives -1.0
+ (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
+ (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
+ (inst and ah-tn #x02) ; Test sign of Inf.
+ (inst jmp :z DONE) ; +Inf gives +Inf.
+ (inst fstp fr0) ; -Inf gives -1.0
(inst fld1)
(inst fchs)
(inst jmp-short DONE)
(inst fstp fr2)
(inst fstp fr0)
(inst fldl2e)
- (inst fmul fr1) ; Now fr0 = x log2(e)
+ (inst fmul fr1) ; Now fr0 = x log2(e)
(inst fst fr1)
(inst frndint)
(inst fsub-sti fr1)
(:translate %log)
(:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
(:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (double-reg)))
(:arg-types double-float)
(:result-types double-float)
(:generator 5
(note-this-location vop :internal-error)
(sc-case x
- (double-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldln2)
- (inst fxch fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0)
- (inst fldln2)
- (inst fxch fr1))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x))))))
- (inst fyl2x))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))
- (inst fyl2x)))
+ (double-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldln2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x))))))
+ (inst fyl2x))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))
+ (inst fyl2x)))
(inst fld fr0)
(case (tn-offset y)
((0 1))
(:translate %log10)
(:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
(:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (double-reg)))
(:arg-types double-float)
(:result-types double-float)
(:generator 5
(note-this-location vop :internal-error)
(sc-case x
- (double-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldlg2)
- (inst fxch fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0)
- (inst fldlg2)
- (inst fxch fr1))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldlg2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x))))))
- (inst fyl2x))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldlg2)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))
- (inst fyl2x)))
+ (double-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldlg2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldlg2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldlg2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x))))))
+ (inst fyl2x))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldlg2)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))
+ (inst fyl2x)))
(inst fld fr0)
(case (tn-offset y)
((0 1))
(define-vop (fpow)
(:translate %pow)
(:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
- (y :scs (double-reg double-stack descriptor-reg) :target fr1))
+ (y :scs (double-reg double-stack descriptor-reg) :target fr1))
(:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
+ :from (:argument 0) :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from (:argument 1) :to :result) fr1)
+ :from (:argument 1) :to :result) fr1)
(:temporary (:sc double-reg :offset fr2-offset
- :from :load :to :result) fr2)
+ :from :load :to :result) fr2)
(:results (r :scs (double-reg)))
(:arg-types double-float double-float)
(:result-types double-float)
(cond
;; x in fr0; y in fr1
((and (sc-is x double-reg) (zerop (tn-offset x))
- (sc-is y double-reg) (= 1 (tn-offset y))))
+ (sc-is y double-reg) (= 1 (tn-offset y))))
;; y in fr1; x not in fr0
((and (sc-is y double-reg) (= 1 (tn-offset y)))
;; Load x to fr0
(sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x)))))
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x)))))
;; x in fr0; y not in fr1
((and (sc-is x double-reg) (zerop (tn-offset x)))
(inst fxch fr1)
;; Now load y to fr0
(sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y))))
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y))))
(inst fxch fr1))
;; x in fr1; y not in fr1
((and (sc-is x double-reg) (= 1 (tn-offset x)))
;; Load y to fr0
(sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y))))
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y))))
(inst fxch fr1))
;; y in fr0;
((and (sc-is y double-reg) (zerop (tn-offset y)))
(inst fxch fr1)
;; Now load x to fr0
(sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x)))))
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x)))))
;; Neither x or y are in either fr0 or fr1
(t
;; Load y then x
(inst fstp fr0)
(inst fstp fr0)
(sc-case y
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset y) 2))))
- (double-stack
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc y))))
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset y) 2))))
+ (double-stack
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc y))))
;; Load x to fr0
(sc-case x
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))
- (double-stack
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc x))))))
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))
+ (double-stack
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc x))))))
;; Now have x at fr0; and y at fr1
(inst fyl2x)
(define-vop (fscalen)
(:translate %scalbn)
(:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
- (y :scs (signed-stack signed-reg) :target temp))
+ (y :scs (signed-stack signed-reg) :target temp))
(:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
+ :from (:argument 0) :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
(:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
(:results (r :scs (double-reg)))
;; Setup x in fr0 and y in fr1
(sc-case x
(double-reg
- (case (tn-offset x)
- (0
- (inst fstp fr1)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (inst fxch fr1))
- (1
- (inst fstp fr0)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (inst fxch fr1))
- (t
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (inst fld (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))))
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fxch fr1))
+ (1
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fxch fr1))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fld (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))))
((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
(inst fscale)
(unless (zerop (tn-offset r))
(inst fstd r))))
(define-vop (fscale)
(:translate %scalb)
(:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
- (y :scs (double-reg double-stack descriptor-reg) :target fr1))
+ (y :scs (double-reg double-stack descriptor-reg) :target fr1))
(:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
+ :from (:argument 0) :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from (:argument 1) :to :result) fr1)
+ :from (:argument 1) :to :result) fr1)
(:results (r :scs (double-reg)))
(:arg-types double-float double-float)
(:result-types double-float)
(cond
;; x in fr0; y in fr1
((and (sc-is x double-reg) (zerop (tn-offset x))
- (sc-is y double-reg) (= 1 (tn-offset y))))
+ (sc-is y double-reg) (= 1 (tn-offset y))))
;; y in fr1; x not in fr0
((and (sc-is y double-reg) (= 1 (tn-offset y)))
;; Load x to fr0
(sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x)))))
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x)))))
;; x in fr0; y not in fr1
((and (sc-is x double-reg) (zerop (tn-offset x)))
(inst fxch fr1)
;; Now load y to fr0
(sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y))))
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y))))
(inst fxch fr1))
;; x in fr1; y not in fr1
((and (sc-is x double-reg) (= 1 (tn-offset x)))
;; Load y to fr0
(sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y))))
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y))))
(inst fxch fr1))
;; y in fr0;
((and (sc-is y double-reg) (zerop (tn-offset y)))
(inst fxch fr1)
;; Now load x to fr0
(sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x)))))
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x)))))
;; Neither x or y are in either fr0 or fr1
(t
;; Load y then x
(inst fstp fr0)
(inst fstp fr0)
(sc-case y
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset y) 2))))
- (double-stack
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc y))))
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset y) 2))))
+ (double-stack
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc y))))
;; Load x to fr0
(sc-case x
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))
- (double-stack
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc x))))))
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))
+ (double-stack
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc x))))))
;; Now have x at fr0; and y at fr1
(inst fscale)
(unless (zerop (tn-offset r))
- (inst fstd r))))
+ (inst fstd r))))
(define-vop (flog1p)
(:translate %log1p)
(:args (x :scs (double-reg) :to :result))
(:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
(:results (y :scs (double-reg)))
(:arg-types double-float)
(inst fstp fr0)
(inst fstp fr0)
(inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))
;; Check the range
- (inst push #x3e947ae1) ; Constant 0.29
+ (inst push #x3e947ae1) ; Constant 0.29
(inst fabs)
(inst fld (make-ea :dword :base esp-tn))
(inst fcompp)
(inst add esp-tn 4)
- (inst fnstsw) ; status word to ax
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45)
(inst jmp :z WITHIN-RANGE)
;; Out of range for fyl2xp1.
(inst fld1)
(inst faddd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 1)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 1)))
(inst fldln2)
(inst fxch fr1)
(inst fyl2x)
WITHIN-RANGE
(inst fldln2)
(inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 1)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 1)))
(inst fyl2xp1)
DONE
(inst fld fr0)
(:translate %log1p)
(:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
(:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (double-reg)))
(:arg-types double-float)
(:result-types double-float)
(:generator 4
(note-this-location vop :internal-error)
(sc-case x
- (double-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldln2)
- (inst fxch fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0)
- (inst fldln2)
- (inst fxch fr1))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
+ (double-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldln2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
(inst fyl2xp1)
(inst fld fr0)
(case (tn-offset y)
(:translate %logb)
(:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
(:temporary (:sc double-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (double-reg)))
(:arg-types double-float)
(:result-types double-float)
(:generator 5
(note-this-location vop :internal-error)
(sc-case x
- (double-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2))))))
- ((double-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (if (sc-is x double-stack)
- (inst fldd (ea-for-df-stack x))
- (inst fldd (ea-for-df-desc x)))))
+ (double-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
(inst fxtract)
(case (tn-offset y)
(0
- (inst fxch fr1))
+ (inst fxch fr1))
(1)
(t (inst fxch fr1)
- (inst fstd y)))))
+ (inst fstd y)))))
(define-vop (fatan)
(:translate %atan)
(:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
(:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
+ :from (:argument 0) :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from (:argument 0) :to :result) fr1)
+ :from (:argument 0) :to :result) fr1)
(:results (r :scs (double-reg)))
(:arg-types double-float)
(:result-types double-float)
(inst fstp fr0)
(inst fstp fr0)
(sc-case x
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2))))
- (double-stack
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc x))))))
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))
+ (double-stack
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc x))))))
(inst fld1)
;; Now have x at fr1; and 1.0 at fr0
(inst fpatan)
(define-vop (fatan2)
(:translate %atan2)
(:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
- (y :scs (double-reg double-stack descriptor-reg) :target fr0))
+ (y :scs (double-reg double-stack descriptor-reg) :target fr0))
(:temporary (:sc double-reg :offset fr0-offset
- :from (:argument 1) :to :result) fr0)
+ :from (:argument 1) :to :result) fr0)
(:temporary (:sc double-reg :offset fr1-offset
- :from (:argument 0) :to :result) fr1)
+ :from (:argument 0) :to :result) fr1)
(:results (r :scs (double-reg)))
(:arg-types double-float double-float)
(:result-types double-float)
(cond
;; y in fr0; x in fr1
((and (sc-is y double-reg) (zerop (tn-offset y))
- (sc-is x double-reg) (= 1 (tn-offset x))))
+ (sc-is x double-reg) (= 1 (tn-offset x))))
;; x in fr1; y not in fr0
((and (sc-is x double-reg) (= 1 (tn-offset x)))
;; Load y to fr0
(sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y)))))
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y)))))
((and (sc-is x double-reg) (zerop (tn-offset x))
- (sc-is y double-reg) (zerop (tn-offset x)))
+ (sc-is y double-reg) (zerop (tn-offset x)))
;; copy x to fr1
(inst fst fr1))
;; y in fr0; x not in fr1
(inst fxch fr1)
;; Now load x to fr0
(sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x))))
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x))))
(inst fxch fr1))
;; y in fr1; x not in fr1
((and (sc-is y double-reg) (= 1 (tn-offset y)))
;; Load x to fr0
(sc-case x
- (double-reg
- (copy-fp-reg-to-fr0 x))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc x))))
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x))))
(inst fxch fr1))
;; x in fr0;
((and (sc-is x double-reg) (zerop (tn-offset x)))
(inst fxch fr1)
;; Now load y to fr0
(sc-case y
- (double-reg
- (copy-fp-reg-to-fr0 y))
- (double-stack
- (inst fstp fr0)
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldd (ea-for-df-desc y)))))
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y)))))
;; Neither y or x are in either fr0 or fr1
(t
;; Load x then y
(inst fstp fr0)
(inst fstp fr0)
(sc-case x
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2))))
- (double-stack
- (inst fldd (ea-for-df-stack x)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc x))))
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))
+ (double-stack
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc x))))
;; Load y to fr0
(sc-case y
- (double-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset y)))))
- (double-stack
- (inst fldd (ea-for-df-stack y)))
- (descriptor-reg
- (inst fldd (ea-for-df-desc y))))))
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset y)))))
+ (double-stack
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc y))))))
;; Now have y at fr0; and x at fr1
(inst fpatan)
;;; to remove the inlined alien routine def.
(macrolet ((frob (func trans op)
- `(define-vop (,func)
- (:args (x :scs (long-reg) :target fr0))
- (:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:ignore fr0)
- (:results (y :scs (long-reg)))
- (:arg-types long-float)
- (:result-types long-float)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note "inline NPX function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,op) ; clobber st0
- (cond ((zerop (tn-offset y))
- (maybe-fp-wait node))
- (t
- (inst fst y)))))))
+ `(define-vop (,func)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:ignore fr0)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline NPX function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op) ; clobber st0
+ (cond ((zerop (tn-offset y))
+ (maybe-fp-wait node))
+ (t
+ (inst fst y)))))))
;; Quick versions of FSIN and FCOS that require the argument to be
;; within range 2^63.
(:translate %tan-quick)
(:args (x :scs (long-reg) :target fr0))
(:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (long-reg)))
(:arg-types long-float)
(:result-types long-float)
(note-this-location vop :internal-error)
(case (tn-offset x)
(0
- (inst fstp fr1))
+ (inst fstp fr1))
(1
- (inst fstp fr0))
+ (inst fstp fr0))
(t
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2)))))
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
(inst fptan)
;; Result is in fr1
(case (tn-offset y)
(0
- (inst fxch fr1))
+ (inst fxch fr1))
(1)
(t
- (inst fxch fr1)
- (inst fstd y)))))
+ (inst fxch fr1)
+ (inst fstd y)))))
;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
;;; the argument is out of range 2^63 and would thus be hopelessly
;;; inaccurate.
(macrolet ((frob (func trans op)
- `(define-vop (,func)
- (:translate ,trans)
- (:args (x :scs (long-reg) :target fr0))
- (:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
- (:temporary (:sc unsigned-reg :offset eax-offset
- :from :argument :to :result) eax)
- (:results (y :scs (long-reg)))
- (:arg-types long-float)
- (:result-types long-float)
- (:policy :fast-safe)
- (:note "inline sin/cos function")
- (:vop-var vop)
- (:save-p :compute-only)
- (:ignore eax)
- (:generator 5
- (note-this-location vop :internal-error)
- (unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
- (inst ,op)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
- (inst jmp :z DONE)
- ;; Else x was out of range so reduce it; ST0 is unchanged.
- (inst fstp fr0) ; Load 0.0
- (inst fldz)
- DONE
- (unless (zerop (tn-offset y))
- (inst fstd y))))))
- (frob fsin %sin fsin)
- (frob fcos %cos fcos))
+ `(define-vop (,func)
+ (:translate ,trans)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :argument :to :result) eax)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline sin/cos function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fstp fr0) ; Load 0.0
+ (inst fldz)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))))
+ (frob fsin %sin fsin)
+ (frob fcos %cos fcos))
(define-vop (ftan)
(:translate %tan)
(:args (x :scs (long-reg) :target fr0))
(:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:temporary (:sc unsigned-reg :offset eax-offset
- :from :argument :to :result) eax)
+ :from :argument :to :result) eax)
(:results (y :scs (long-reg)))
(:arg-types long-float)
(:result-types long-float)
(note-this-location vop :internal-error)
(case (tn-offset x)
(0
- (inst fstp fr1))
+ (inst fstp fr1))
(1
- (inst fstp fr0))
+ (inst fstp fr0))
(t
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2)))))
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
(inst fptan)
- (inst fnstsw) ; status word to ax
- (inst and ah-tn #x04) ; C2
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
(inst jmp :z DONE)
;; Else x was out of range so reduce it; ST0 is unchanged.
- (inst fldz) ; Load 0.0
+ (inst fldz) ; Load 0.0
(inst fxch fr1)
DONE
;; Result is in fr1
(case (tn-offset y)
(0
- (inst fxch fr1))
+ (inst fxch fr1))
(1)
(t
- (inst fxch fr1)
- (inst fstd y)))))
+ (inst fxch fr1)
+ (inst fstd y)))))
;;; Modified exp that handles the following special cases:
;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
(:args (x :scs (long-reg) :target fr0))
(:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
(:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:temporary (:sc long-reg :offset fr2-offset
- :from :argument :to :result) fr2)
+ :from :argument :to :result) fr2)
(:results (y :scs (long-reg)))
(:arg-types long-float)
(:result-types long-float)
(:generator 5
(note-this-location vop :internal-error)
(unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
- (unless (location= x y)
- (inst fst x))) ; maybe save it
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
;; Check for Inf or NaN
(inst fxam)
(inst fnstsw)
(inst sahf)
- (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
- (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
- (inst and ah-tn #x02) ; Test sign of Inf.
- (inst jmp :z DONE) ; +Inf gives +Inf.
- (inst fstp fr0) ; -Inf gives 0
+ (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
+ (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
+ (inst and ah-tn #x02) ; Test sign of Inf.
+ (inst jmp :z DONE) ; +Inf gives +Inf.
+ (inst fstp fr0) ; -Inf gives 0
(inst fldz)
(inst jmp-short DONE)
NOINFNAN
(inst fld fr0)
DONE
(unless (zerop (tn-offset y))
- (inst fstd y))))
+ (inst fstd y))))
;;; Expm1 = exp(x) - 1.
;;; Handles the following special cases:
(:args (x :scs (long-reg) :target fr0))
(:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
(:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:temporary (:sc long-reg :offset fr2-offset
- :from :argument :to :result) fr2)
+ :from :argument :to :result) fr2)
(:results (y :scs (long-reg)))
(:arg-types long-float)
(:result-types long-float)
(:generator 5
(note-this-location vop :internal-error)
(unless (zerop (tn-offset x))
- (inst fxch x) ; x to top of stack
+ (inst fxch x) ; x to top of stack
(unless (location= x y)
- (inst fst x))) ; maybe save it
+ (inst fst x))) ; maybe save it
;; Check for Inf or NaN
(inst fxam)
(inst fnstsw)
(inst sahf)
- (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
- (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
- (inst and ah-tn #x02) ; Test sign of Inf.
- (inst jmp :z DONE) ; +Inf gives +Inf.
- (inst fstp fr0) ; -Inf gives -1.0
+ (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
+ (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
+ (inst and ah-tn #x02) ; Test sign of Inf.
+ (inst jmp :z DONE) ; +Inf gives +Inf.
+ (inst fstp fr0) ; -Inf gives -1.0
(inst fld1)
(inst fchs)
(inst jmp-short DONE)
(inst fstp fr2)
(inst fstp fr0)
(inst fldl2e)
- (inst fmul fr1) ; Now fr0 = x log2(e)
+ (inst fmul fr1) ; Now fr0 = x log2(e)
(inst fst fr1)
(inst frndint)
(inst fsub-sti fr1)
(:translate %log)
(:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
(:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (long-reg)))
(:arg-types long-float)
(:result-types long-float)
(:generator 5
(note-this-location vop :internal-error)
(sc-case x
- (long-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldln2)
- (inst fxch fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0)
- (inst fldln2)
- (inst fxch fr1))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x))))))
- (inst fyl2x))
- ((long-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (if (sc-is x long-stack)
- (inst fldl (ea-for-lf-stack x))
- (inst fldl (ea-for-lf-desc x)))
- (inst fyl2x)))
+ (long-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldln2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x))))))
+ (inst fyl2x))
+ ((long-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))
+ (inst fyl2x)))
(inst fld fr0)
(case (tn-offset y)
((0 1))
(:translate %log10)
(:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
(:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (long-reg)))
(:arg-types long-float)
(:result-types long-float)
(:generator 5
(note-this-location vop :internal-error)
(sc-case x
- (long-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldlg2)
- (inst fxch fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0)
- (inst fldlg2)
- (inst fxch fr1))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldlg2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x))))))
- (inst fyl2x))
- ((long-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldlg2)
- (if (sc-is x long-stack)
- (inst fldl (ea-for-lf-stack x))
- (inst fldl (ea-for-lf-desc x)))
- (inst fyl2x)))
+ (long-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldlg2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldlg2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldlg2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x))))))
+ (inst fyl2x))
+ ((long-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldlg2)
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))
+ (inst fyl2x)))
(inst fld fr0)
(case (tn-offset y)
((0 1))
(define-vop (fpow)
(:translate %pow)
(:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
- (y :scs (long-reg long-stack descriptor-reg) :target fr1))
+ (y :scs (long-reg long-stack descriptor-reg) :target fr1))
(:temporary (:sc long-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
+ :from (:argument 0) :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from (:argument 1) :to :result) fr1)
+ :from (:argument 1) :to :result) fr1)
(:temporary (:sc long-reg :offset fr2-offset
- :from :load :to :result) fr2)
+ :from :load :to :result) fr2)
(:results (r :scs (long-reg)))
(:arg-types long-float long-float)
(:result-types long-float)
(cond
;; x in fr0; y in fr1
((and (sc-is x long-reg) (zerop (tn-offset x))
- (sc-is y long-reg) (= 1 (tn-offset y))))
+ (sc-is y long-reg) (= 1 (tn-offset y))))
;; y in fr1; x not in fr0
((and (sc-is y long-reg) (= 1 (tn-offset y)))
;; Load x to fr0
(sc-case x
- (long-reg
- (copy-fp-reg-to-fr0 x))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc x)))))
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x)))))
;; x in fr0; y not in fr1
((and (sc-is x long-reg) (zerop (tn-offset x)))
(inst fxch fr1)
;; Now load y to fr0
(sc-case y
- (long-reg
- (copy-fp-reg-to-fr0 y))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc y))))
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y))))
(inst fxch fr1))
;; x in fr1; y not in fr1
((and (sc-is x long-reg) (= 1 (tn-offset x)))
;; Load y to fr0
(sc-case y
- (long-reg
- (copy-fp-reg-to-fr0 y))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc y))))
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y))))
(inst fxch fr1))
;; y in fr0;
((and (sc-is y long-reg) (zerop (tn-offset y)))
(inst fxch fr1)
;; Now load x to fr0
(sc-case x
- (long-reg
- (copy-fp-reg-to-fr0 x))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc x)))))
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x)))))
;; Neither x or y are in either fr0 or fr1
(t
;; Load y then x
(inst fstp fr0)
(inst fstp fr0)
(sc-case y
- (long-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset y) 2))))
- (long-stack
- (inst fldl (ea-for-lf-stack y)))
- (descriptor-reg
- (inst fldl (ea-for-lf-desc y))))
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset y) 2))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc y))))
;; Load x to fr0
(sc-case x
- (long-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))
- (long-stack
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fldl (ea-for-lf-desc x))))))
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc x))))))
;; Now have x at fr0; and y at fr1
(inst fyl2x)
(define-vop (fscalen)
(:translate %scalbn)
(:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
- (y :scs (signed-stack signed-reg) :target temp))
+ (y :scs (signed-stack signed-reg) :target temp))
(:temporary (:sc long-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
+ :from (:argument 0) :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
(:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
(:results (r :scs (long-reg)))
;; Setup x in fr0 and y in fr1
(sc-case x
(long-reg
- (case (tn-offset x)
- (0
- (inst fstp fr1)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (inst fxch fr1))
- (1
- (inst fstp fr0)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (inst fxch fr1))
- (t
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (inst fld (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))))
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fxch fr1))
+ (1
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fxch fr1))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fld (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))))
((long-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (sc-case y
- (signed-reg
- (inst mov temp y)
- (inst fild temp))
- (signed-stack
- (inst fild y)))
- (if (sc-is x long-stack)
- (inst fldl (ea-for-lf-stack x))
- (inst fldl (ea-for-lf-desc x)))))
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))))
(inst fscale)
(unless (zerop (tn-offset r))
(inst fstd r))))
(define-vop (fscale)
(:translate %scalb)
(:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
- (y :scs (long-reg long-stack descriptor-reg) :target fr1))
+ (y :scs (long-reg long-stack descriptor-reg) :target fr1))
(:temporary (:sc long-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
+ :from (:argument 0) :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from (:argument 1) :to :result) fr1)
+ :from (:argument 1) :to :result) fr1)
(:results (r :scs (long-reg)))
(:arg-types long-float long-float)
(:result-types long-float)
(cond
;; x in fr0; y in fr1
((and (sc-is x long-reg) (zerop (tn-offset x))
- (sc-is y long-reg) (= 1 (tn-offset y))))
+ (sc-is y long-reg) (= 1 (tn-offset y))))
;; y in fr1; x not in fr0
((and (sc-is y long-reg) (= 1 (tn-offset y)))
;; Load x to fr0
(sc-case x
- (long-reg
- (copy-fp-reg-to-fr0 x))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc x)))))
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x)))))
;; x in fr0; y not in fr1
((and (sc-is x long-reg) (zerop (tn-offset x)))
(inst fxch fr1)
;; Now load y to fr0
(sc-case y
- (long-reg
- (copy-fp-reg-to-fr0 y))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc y))))
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y))))
(inst fxch fr1))
;; x in fr1; y not in fr1
((and (sc-is x long-reg) (= 1 (tn-offset x)))
;; Load y to fr0
(sc-case y
- (long-reg
- (copy-fp-reg-to-fr0 y))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc y))))
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y))))
(inst fxch fr1))
;; y in fr0;
((and (sc-is y long-reg) (zerop (tn-offset y)))
(inst fxch fr1)
;; Now load x to fr0
(sc-case x
- (long-reg
- (copy-fp-reg-to-fr0 x))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc x)))))
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x)))))
;; Neither x or y are in either fr0 or fr1
(t
;; Load y then x
(inst fstp fr0)
(inst fstp fr0)
(sc-case y
- (long-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset y) 2))))
- (long-stack
- (inst fldl (ea-for-lf-stack y)))
- (descriptor-reg
- (inst fldl (ea-for-lf-desc y))))
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset y) 2))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc y))))
;; Load x to fr0
(sc-case x
- (long-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))
- (long-stack
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fldl (ea-for-lf-desc x))))))
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc x))))))
;; Now have x at fr0; and y at fr1
(inst fscale)
(unless (zerop (tn-offset r))
- (inst fstd r))))
+ (inst fstd r))))
(define-vop (flog1p)
(:translate %log1p)
(:args (x :scs (long-reg) :to :result))
(:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
(:results (y :scs (long-reg)))
(:arg-types long-float)
(inst fstp fr0)
(inst fstp fr0)
(inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))
;; Check the range
- (inst push #x3e947ae1) ; Constant 0.29
+ (inst push #x3e947ae1) ; Constant 0.29
(inst fabs)
(inst fld (make-ea :dword :base esp-tn))
(inst fcompp)
(inst add esp-tn 4)
- (inst fnstsw) ; status word to ax
+ (inst fnstsw) ; status word to ax
(inst and ah-tn #x45)
(inst jmp :z WITHIN-RANGE)
;; Out of range for fyl2xp1.
(inst fld1)
(inst faddd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 1)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 1)))
(inst fldln2)
(inst fxch fr1)
(inst fyl2x)
WITHIN-RANGE
(inst fldln2)
(inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 1)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 1)))
(inst fyl2xp1)
DONE
(inst fld fr0)
(:translate %log1p)
(:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
(:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (long-reg)))
(:arg-types long-float)
(:result-types long-float)
(:note "inline log1p function")
(:generator 5
(sc-case x
- (long-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1)
- (inst fldln2)
- (inst fxch fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0)
- (inst fldln2)
- (inst fxch fr1))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset x)))))))
- ((long-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldln2)
- (if (sc-is x long-stack)
- (inst fldl (ea-for-lf-stack x))
- (inst fldl (ea-for-lf-desc x)))))
+ (long-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldln2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))))
+ ((long-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))))
(inst fyl2xp1)
(inst fld fr0)
(case (tn-offset y)
(:translate %logb)
(:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
(:temporary (:sc long-reg :offset fr0-offset
- :from :argument :to :result) fr0)
+ :from :argument :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from :argument :to :result) fr1)
+ :from :argument :to :result) fr1)
(:results (y :scs (long-reg)))
(:arg-types long-float)
(:result-types long-float)
(:generator 5
(note-this-location vop :internal-error)
(sc-case x
- (long-reg
- (case (tn-offset x)
- (0
- ;; x is in fr0
- (inst fstp fr1))
- (1
- ;; x is in fr1
- (inst fstp fr0))
- (t
- ;; x is in a FP reg, not fr0 or fr1
- (inst fstp fr0)
- (inst fstp fr0)
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2))))))
- ((long-stack descriptor-reg)
- (inst fstp fr0)
- (inst fstp fr0)
- (if (sc-is x long-stack)
- (inst fldl (ea-for-lf-stack x))
- (inst fldl (ea-for-lf-desc x)))))
+ (long-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))))
+ ((long-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))))
(inst fxtract)
(case (tn-offset y)
(0
- (inst fxch fr1))
+ (inst fxch fr1))
(1)
(t (inst fxch fr1)
- (inst fstd y)))))
+ (inst fstd y)))))
(define-vop (fatan)
(:translate %atan)
(:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
(:temporary (:sc long-reg :offset fr0-offset
- :from (:argument 0) :to :result) fr0)
+ :from (:argument 0) :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from (:argument 0) :to :result) fr1)
+ :from (:argument 0) :to :result) fr1)
(:results (r :scs (long-reg)))
(:arg-types long-float)
(:result-types long-float)
(inst fstp fr0)
(inst fstp fr0)
(sc-case x
- (long-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2))))
- (long-stack
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fldl (ea-for-lf-desc x))))))
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc x))))))
(inst fld1)
;; Now have x at fr1; and 1.0 at fr0
(inst fpatan)
(define-vop (fatan2)
(:translate %atan2)
(:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
- (y :scs (long-reg long-stack descriptor-reg) :target fr0))
+ (y :scs (long-reg long-stack descriptor-reg) :target fr0))
(:temporary (:sc long-reg :offset fr0-offset
- :from (:argument 1) :to :result) fr0)
+ :from (:argument 1) :to :result) fr0)
(:temporary (:sc long-reg :offset fr1-offset
- :from (:argument 0) :to :result) fr1)
+ :from (:argument 0) :to :result) fr1)
(:results (r :scs (long-reg)))
(:arg-types long-float long-float)
(:result-types long-float)
(cond
;; y in fr0; x in fr1
((and (sc-is y long-reg) (zerop (tn-offset y))
- (sc-is x long-reg) (= 1 (tn-offset x))))
+ (sc-is x long-reg) (= 1 (tn-offset x))))
;; x in fr1; y not in fr0
((and (sc-is x long-reg) (= 1 (tn-offset x)))
;; Load y to fr0
(sc-case y
- (long-reg
- (copy-fp-reg-to-fr0 y))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc y)))))
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y)))))
;; y in fr0; x not in fr1
((and (sc-is y long-reg) (zerop (tn-offset y)))
(inst fxch fr1)
;; Now load x to fr0
(sc-case x
- (long-reg
- (copy-fp-reg-to-fr0 x))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc x))))
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x))))
(inst fxch fr1))
;; y in fr1; x not in fr1
((and (sc-is y long-reg) (= 1 (tn-offset y)))
;; Load x to fr0
(sc-case x
- (long-reg
- (copy-fp-reg-to-fr0 x))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc x))))
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x))))
(inst fxch fr1))
;; x in fr0;
((and (sc-is x long-reg) (zerop (tn-offset x)))
(inst fxch fr1)
;; Now load y to fr0
(sc-case y
- (long-reg
- (copy-fp-reg-to-fr0 y))
- (long-stack
- (inst fstp fr0)
- (inst fldl (ea-for-lf-stack y)))
- (descriptor-reg
- (inst fstp fr0)
- (inst fldl (ea-for-lf-desc y)))))
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y)))))
;; Neither y or x are in either fr0 or fr1
(t
;; Load x then y
(inst fstp fr0)
(inst fstp fr0)
(sc-case x
- (long-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (- (tn-offset x) 2))))
- (long-stack
- (inst fldl (ea-for-lf-stack x)))
- (descriptor-reg
- (inst fldl (ea-for-lf-desc x))))
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc x))))
;; Load y to fr0
(sc-case y
- (long-reg
- (inst fldd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (1- (tn-offset y)))))
- (long-stack
- (inst fldl (ea-for-lf-stack y)))
- (descriptor-reg
- (inst fldl (ea-for-lf-desc y))))))
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset y)))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc y))))))
;; Now have y at fr0; and x at fr1
(inst fpatan)
(define-vop (make-complex-single-float)
(:translate complex)
(:args (real :scs (single-reg) :to :result :target r
- :load-if (not (location= real r)))
- (imag :scs (single-reg) :to :save))
+ :load-if (not (location= real r)))
+ (imag :scs (single-reg) :to :save))
(:arg-types single-float single-float)
(:results (r :scs (complex-single-reg) :from (:argument 0)
- :load-if (not (sc-is r complex-single-stack))))
+ :load-if (not (sc-is r complex-single-stack))))
(:result-types complex-single-float)
(:note "inline complex single-float creation")
(:policy :fast-safe)
(sc-case r
(complex-single-reg
(let ((r-real (complex-double-reg-real-tn r)))
- (unless (location= real r-real)
- (cond ((zerop (tn-offset r-real))
- (copy-fp-reg-to-fr0 real))
- ((zerop (tn-offset real))
- (inst fstd r-real))
- (t
- (inst fxch real)
- (inst fstd r-real)
- (inst fxch real)))))
+ (unless (location= real r-real)
+ (cond ((zerop (tn-offset r-real))
+ (copy-fp-reg-to-fr0 real))
+ ((zerop (tn-offset real))
+ (inst fstd r-real))
+ (t
+ (inst fxch real)
+ (inst fstd r-real)
+ (inst fxch real)))))
(let ((r-imag (complex-double-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (cond ((zerop (tn-offset imag))
- (inst fstd r-imag))
- (t
- (inst fxch imag)
- (inst fstd r-imag)
- (inst fxch imag))))))
+ (unless (location= imag r-imag)
+ (cond ((zerop (tn-offset imag))
+ (inst fstd r-imag))
+ (t
+ (inst fxch imag)
+ (inst fstd r-imag)
+ (inst fxch imag))))))
(complex-single-stack
(unless (location= real r)
- (cond ((zerop (tn-offset real))
- (inst fst (ea-for-csf-real-stack r)))
- (t
- (inst fxch real)
- (inst fst (ea-for-csf-real-stack r))
- (inst fxch real))))
+ (cond ((zerop (tn-offset real))
+ (inst fst (ea-for-csf-real-stack r)))
+ (t
+ (inst fxch real)
+ (inst fst (ea-for-csf-real-stack r))
+ (inst fxch real))))
(inst fxch imag)
(inst fst (ea-for-csf-imag-stack r))
(inst fxch imag)))))
(define-vop (make-complex-double-float)
(:translate complex)
(:args (real :scs (double-reg) :target r
- :load-if (not (location= real r)))
- (imag :scs (double-reg) :to :save))
+ :load-if (not (location= real r)))
+ (imag :scs (double-reg) :to :save))
(:arg-types double-float double-float)
(:results (r :scs (complex-double-reg) :from (:argument 0)
- :load-if (not (sc-is r complex-double-stack))))
+ :load-if (not (sc-is r complex-double-stack))))
(:result-types complex-double-float)
(:note "inline complex double-float creation")
(:policy :fast-safe)
(sc-case r
(complex-double-reg
(let ((r-real (complex-double-reg-real-tn r)))
- (unless (location= real r-real)
- (cond ((zerop (tn-offset r-real))
- (copy-fp-reg-to-fr0 real))
- ((zerop (tn-offset real))
- (inst fstd r-real))
- (t
- (inst fxch real)
- (inst fstd r-real)
- (inst fxch real)))))
+ (unless (location= real r-real)
+ (cond ((zerop (tn-offset r-real))
+ (copy-fp-reg-to-fr0 real))
+ ((zerop (tn-offset real))
+ (inst fstd r-real))
+ (t
+ (inst fxch real)
+ (inst fstd r-real)
+ (inst fxch real)))))
(let ((r-imag (complex-double-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (cond ((zerop (tn-offset imag))
- (inst fstd r-imag))
- (t
- (inst fxch imag)
- (inst fstd r-imag)
- (inst fxch imag))))))
+ (unless (location= imag r-imag)
+ (cond ((zerop (tn-offset imag))
+ (inst fstd r-imag))
+ (t
+ (inst fxch imag)
+ (inst fstd r-imag)
+ (inst fxch imag))))))
(complex-double-stack
(unless (location= real r)
- (cond ((zerop (tn-offset real))
- (inst fstd (ea-for-cdf-real-stack r)))
- (t
- (inst fxch real)
- (inst fstd (ea-for-cdf-real-stack r))
- (inst fxch real))))
+ (cond ((zerop (tn-offset real))
+ (inst fstd (ea-for-cdf-real-stack r)))
+ (t
+ (inst fxch real)
+ (inst fstd (ea-for-cdf-real-stack r))
+ (inst fxch real))))
(inst fxch imag)
(inst fstd (ea-for-cdf-imag-stack r))
(inst fxch imag)))))
(define-vop (make-complex-long-float)
(:translate complex)
(:args (real :scs (long-reg) :target r
- :load-if (not (location= real r)))
- (imag :scs (long-reg) :to :save))
+ :load-if (not (location= real r)))
+ (imag :scs (long-reg) :to :save))
(:arg-types long-float long-float)
(:results (r :scs (complex-long-reg) :from (:argument 0)
- :load-if (not (sc-is r complex-long-stack))))
+ :load-if (not (sc-is r complex-long-stack))))
(:result-types complex-long-float)
(:note "inline complex long-float creation")
(:policy :fast-safe)
(sc-case r
(complex-long-reg
(let ((r-real (complex-double-reg-real-tn r)))
- (unless (location= real r-real)
- (cond ((zerop (tn-offset r-real))
- (copy-fp-reg-to-fr0 real))
- ((zerop (tn-offset real))
- (inst fstd r-real))
- (t
- (inst fxch real)
- (inst fstd r-real)
- (inst fxch real)))))
+ (unless (location= real r-real)
+ (cond ((zerop (tn-offset r-real))
+ (copy-fp-reg-to-fr0 real))
+ ((zerop (tn-offset real))
+ (inst fstd r-real))
+ (t
+ (inst fxch real)
+ (inst fstd r-real)
+ (inst fxch real)))))
(let ((r-imag (complex-double-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (cond ((zerop (tn-offset imag))
- (inst fstd r-imag))
- (t
- (inst fxch imag)
- (inst fstd r-imag)
- (inst fxch imag))))))
+ (unless (location= imag r-imag)
+ (cond ((zerop (tn-offset imag))
+ (inst fstd r-imag))
+ (t
+ (inst fxch imag)
+ (inst fstd r-imag)
+ (inst fxch imag))))))
(complex-long-stack
(unless (location= real r)
- (cond ((zerop (tn-offset real))
- (store-long-float (ea-for-clf-real-stack r)))
- (t
- (inst fxch real)
- (store-long-float (ea-for-clf-real-stack r))
- (inst fxch real))))
+ (cond ((zerop (tn-offset real))
+ (store-long-float (ea-for-clf-real-stack r)))
+ (t
+ (inst fxch real)
+ (store-long-float (ea-for-clf-real-stack r))
+ (inst fxch real))))
(inst fxch imag)
(store-long-float (ea-for-clf-imag-stack r))
(inst fxch imag)))))
(:policy :fast-safe)
(:generator 3
(cond ((sc-is x complex-single-reg complex-double-reg
- #!+long-float complex-long-reg)
- (let ((value-tn
- (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ offset (tn-offset x)))))
- (unless (location= value-tn r)
- (cond ((zerop (tn-offset r))
- (copy-fp-reg-to-fr0 value-tn))
- ((zerop (tn-offset value-tn))
- (inst fstd r))
- (t
- (inst fxch value-tn)
- (inst fstd r)
- (inst fxch value-tn))))))
- ((sc-is r single-reg)
- (let ((ea (sc-case x
- (complex-single-stack
- (ecase offset
- (0 (ea-for-csf-real-stack x))
- (1 (ea-for-csf-imag-stack x))))
- (descriptor-reg
- (ecase offset
- (0 (ea-for-csf-real-desc x))
- (1 (ea-for-csf-imag-desc x)))))))
- (with-empty-tn@fp-top(r)
- (inst fld ea))))
- ((sc-is r double-reg)
- (let ((ea (sc-case x
- (complex-double-stack
- (ecase offset
- (0 (ea-for-cdf-real-stack x))
- (1 (ea-for-cdf-imag-stack x))))
- (descriptor-reg
- (ecase offset
- (0 (ea-for-cdf-real-desc x))
- (1 (ea-for-cdf-imag-desc x)))))))
- (with-empty-tn@fp-top(r)
- (inst fldd ea))))
- #!+long-float
- ((sc-is r long-reg)
- (let ((ea (sc-case x
- (complex-long-stack
- (ecase offset
- (0 (ea-for-clf-real-stack x))
- (1 (ea-for-clf-imag-stack x))))
- (descriptor-reg
- (ecase offset
- (0 (ea-for-clf-real-desc x))
- (1 (ea-for-clf-imag-desc x)))))))
- (with-empty-tn@fp-top(r)
- (inst fldl ea))))
- (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
+ #!+long-float complex-long-reg)
+ (let ((value-tn
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ offset (tn-offset x)))))
+ (unless (location= value-tn r)
+ (cond ((zerop (tn-offset r))
+ (copy-fp-reg-to-fr0 value-tn))
+ ((zerop (tn-offset value-tn))
+ (inst fstd r))
+ (t
+ (inst fxch value-tn)
+ (inst fstd r)
+ (inst fxch value-tn))))))
+ ((sc-is r single-reg)
+ (let ((ea (sc-case x
+ (complex-single-stack
+ (ecase offset
+ (0 (ea-for-csf-real-stack x))
+ (1 (ea-for-csf-imag-stack x))))
+ (descriptor-reg
+ (ecase offset
+ (0 (ea-for-csf-real-desc x))
+ (1 (ea-for-csf-imag-desc x)))))))
+ (with-empty-tn@fp-top(r)
+ (inst fld ea))))
+ ((sc-is r double-reg)
+ (let ((ea (sc-case x
+ (complex-double-stack
+ (ecase offset
+ (0 (ea-for-cdf-real-stack x))
+ (1 (ea-for-cdf-imag-stack x))))
+ (descriptor-reg
+ (ecase offset
+ (0 (ea-for-cdf-real-desc x))
+ (1 (ea-for-cdf-imag-desc x)))))))
+ (with-empty-tn@fp-top(r)
+ (inst fldd ea))))
+ #!+long-float
+ ((sc-is r long-reg)
+ (let ((ea (sc-case x
+ (complex-long-stack
+ (ecase offset
+ (0 (ea-for-clf-real-stack x))
+ (1 (ea-for-clf-imag-stack x))))
+ (descriptor-reg
+ (ecase offset
+ (0 (ea-for-clf-real-desc x))
+ (1 (ea-for-clf-imag-desc x)))))))
+ (with-empty-tn@fp-top(r)
+ (inst fldl ea))))
+ (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
(define-vop (realpart/complex-single-float complex-float-value)
(:translate realpart)
(:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(define-vop (realpart/complex-double-float complex-float-value)
(:translate realpart)
(:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(define-vop (realpart/complex-long-float complex-float-value)
(:translate realpart)
(:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-long-float)
(:results (r :scs (long-reg)))
(:result-types long-float)
(define-vop (imagpart/complex-single-float complex-float-value)
(:translate imagpart)
(:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(define-vop (imagpart/complex-double-float complex-float-value)
(:translate imagpart)
(:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(define-vop (imagpart/complex-long-float complex-float-value)
(:translate imagpart)
(:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
- :target r))
+ :target r))
(:arg-types complex-long-float)
(:results (r :scs (long-reg)))
(:result-types long-float)
(defun offset-next (value dstate)
(declare (type integer value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(+ (sb!disassem:dstate-next-addr dstate) value))
(defparameter *default-address-size*
(defun print-reg-with-width (value width stream dstate)
(declare (ignore dstate))
(princ (aref (ecase width
- (:byte *byte-reg-names*)
- (:word *word-reg-names*)
- (:dword *dword-reg-names*))
- value)
- stream)
+ (:byte *byte-reg-names*)
+ (:word *word-reg-names*)
+ (:dword *dword-reg-names*))
+ value)
+ stream)
;; XXX plus should do some source-var notes
)
(defun print-reg (value stream dstate)
(declare (type reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value
- (sb!disassem:dstate-get-prop dstate 'width)
- stream
- dstate))
+ (sb!disassem:dstate-get-prop dstate 'width)
+ stream
+ dstate))
(defun print-word-reg (value stream dstate)
(declare (type reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value
- (or (sb!disassem:dstate-get-prop dstate 'word-width)
- +default-operand-size+)
- stream
- dstate))
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)
+ stream
+ dstate))
(defun print-byte-reg (value stream dstate)
(declare (type reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value :byte stream dstate))
(defun print-addr-reg (value stream dstate)
(declare (type reg value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(print-reg-with-width value *default-address-size* stream dstate))
(defun print-reg/mem (value stream dstate)
(declare (type (or list reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(if (typep value 'reg)
(print-reg value stream dstate)
(print-mem-access value stream nil dstate)))
;; memory references.
(defun print-sized-reg/mem (value stream dstate)
(declare (type (or list reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(if (typep value 'reg)
(print-reg value stream dstate)
(print-mem-access value stream t dstate)))
(defun print-byte-reg/mem (value stream dstate)
(declare (type (or list reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(if (typep value 'reg)
(print-byte-reg value stream dstate)
(print-mem-access value stream t dstate)))
(defun print-word-reg/mem (value stream dstate)
(declare (type (or list reg) value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
(if (typep value 'reg)
(print-word-reg value stream dstate)
(print-mem-access value stream nil dstate)))
;;; obvious default value (e.g., 1 for the index-scale).
(defun prefilter-reg/mem (value dstate)
(declare (type list value)
- (type sb!disassem:disassem-state dstate))
+ (type sb!disassem:disassem-state dstate))
(let ((mod (car value))
- (r/m (cadr value)))
+ (r/m (cadr value)))
(declare (type (unsigned-byte 2) mod)
- (type (unsigned-byte 3) r/m))
+ (type (unsigned-byte 3) r/m))
(cond ((= mod #b11)
- ;; registers
- r/m)
- ((= r/m #b100)
- ;; sib byte
- (let ((sib (sb!disassem:read-suffix 8 dstate)))
- (declare (type (unsigned-byte 8) sib))
- (let ((base-reg (ldb (byte 3 0) sib))
- (index-reg (ldb (byte 3 3) sib))
- (index-scale (ldb (byte 2 6) sib)))
- (declare (type (unsigned-byte 3) base-reg index-reg)
- (type (unsigned-byte 2) index-scale))
- (let* ((offset
- (case mod
- (#b00
- (if (= base-reg #b101)
- (sb!disassem:read-signed-suffix 32 dstate)
- nil))
- (#b01
- (sb!disassem:read-signed-suffix 8 dstate))
- (#b10
- (sb!disassem:read-signed-suffix 32 dstate)))))
- (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
- offset
- (if (= index-reg #b100) nil index-reg)
- (ash 1 index-scale))))))
- ((and (= mod #b00) (= r/m #b101))
- (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
- ((= mod #b00)
- (list r/m))
- ((= mod #b01)
- (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
- (t ; (= mod #b10)
- (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
+ ;; registers
+ r/m)
+ ((= r/m #b100)
+ ;; sib byte
+ (let ((sib (sb!disassem:read-suffix 8 dstate)))
+ (declare (type (unsigned-byte 8) sib))
+ (let ((base-reg (ldb (byte 3 0) sib))
+ (index-reg (ldb (byte 3 3) sib))
+ (index-scale (ldb (byte 2 6) sib)))
+ (declare (type (unsigned-byte 3) base-reg index-reg)
+ (type (unsigned-byte 2) index-scale))
+ (let* ((offset
+ (case mod
+ (#b00
+ (if (= base-reg #b101)
+ (sb!disassem:read-signed-suffix 32 dstate)
+ nil))
+ (#b01
+ (sb!disassem:read-signed-suffix 8 dstate))
+ (#b10
+ (sb!disassem:read-signed-suffix 32 dstate)))))
+ (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
+ offset
+ (if (= index-reg #b100) nil index-reg)
+ (ash 1 index-scale))))))
+ ((and (= mod #b00) (= r/m #b101))
+ (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
+ ((= mod #b00)
+ (list r/m))
+ ((= mod #b01)
+ (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
+ (t ; (= mod #b10)
+ (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
;;; This is a sort of bogus prefilter that just stores the info globally for
;;; other people to use; it probably never gets printed.
(defun prefilter-width (value dstate)
(setf (sb!disassem:dstate-get-prop dstate 'width)
- (if (zerop value)
- :byte
- (let ((word-width
- ;; set by a prefix instruction
- (or (sb!disassem:dstate-get-prop dstate 'word-width)
- +default-operand-size+)))
- (when (not (eql word-width +default-operand-size+))
- ;; Reset it.
- (setf (sb!disassem:dstate-get-prop dstate 'word-width)
- +default-operand-size+))
- word-width))))
+ (if (zerop value)
+ :byte
+ (let ((word-width
+ ;; set by a prefix instruction
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)))
+ (when (not (eql word-width +default-operand-size+))
+ ;; Reset it.
+ (setf (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+))
+ word-width))))
(defun read-address (value dstate)
- (declare (ignore value)) ; always nil anyway
+ (declare (ignore value)) ; always nil anyway
(sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
(defun width-bits (width)
:sign-extend t
:use-label #'offset-next
:printer (lambda (value stream dstate)
- (sb!disassem:maybe-note-assembler-routine value nil dstate)
- (print-label value stream dstate)))
+ (sb!disassem:maybe-note-assembler-routine value nil dstate)
+ (print-label value stream dstate)))
(sb!disassem:define-arg-type accum
:printer (lambda (value stream dstate)
- (declare (ignore value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
- (print-reg 0 stream dstate)))
+ (declare (ignore value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-reg 0 stream dstate)))
(sb!disassem:define-arg-type word-accum
:printer (lambda (value stream dstate)
- (declare (ignore value)
- (type stream stream)
- (type sb!disassem:disassem-state dstate))
- (print-word-reg 0 stream dstate)))
+ (declare (ignore value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-word-reg 0 stream dstate)))
(sb!disassem:define-arg-type reg
:printer #'print-reg)
(sb!disassem:define-arg-type imm-data
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-suffix
- (width-bits (sb!disassem:dstate-get-prop dstate 'width))
- dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix
+ (width-bits (sb!disassem:dstate-get-prop dstate 'width))
+ dstate)))
(sb!disassem:define-arg-type signed-imm-data
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
- (sb!disassem:read-signed-suffix (width-bits width) dstate))))
+ (declare (ignore value)) ; always nil anyway
+ (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
+ (sb!disassem:read-signed-suffix (width-bits width) dstate))))
(sb!disassem:define-arg-type signed-imm-byte
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 8 dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 8 dstate)))
(sb!disassem:define-arg-type signed-imm-dword
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate)))
(sb!disassem:define-arg-type imm-word
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (let ((width
- (or (sb!disassem:dstate-get-prop dstate 'word-width)
- +default-operand-size+)))
- (sb!disassem:read-suffix (width-bits width) dstate))))
+ (declare (ignore value)) ; always nil anyway
+ (let ((width
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)))
+ (sb!disassem:read-suffix (width-bits width) dstate))))
(sb!disassem:define-arg-type signed-imm-word
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (let ((width
- (or (sb!disassem:dstate-get-prop dstate 'word-width)
- +default-operand-size+)))
- (sb!disassem:read-signed-suffix (width-bits width) dstate))))
+ (declare (ignore value)) ; always nil anyway
+ (let ((width
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)))
+ (sb!disassem:read-signed-suffix (width-bits width) dstate))))
;;; needed for the ret imm16 instruction
(sb!disassem:define-arg-type imm-word-16
:prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-suffix 16 dstate)))
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix 16 dstate)))
(sb!disassem:define-arg-type reg/mem
:prefilter #'prefilter-reg/mem
value)
) ; EVAL-WHEN
(sb!disassem:define-arg-type fp-reg
- :prefilter #'prefilter-fp-reg
- :printer #'print-fp-reg)
+ :prefilter #'prefilter-fp-reg
+ :printer #'print-fp-reg)
(sb!disassem:define-arg-type width
:prefilter #'prefilter-width
:printer (lambda (value stream dstate)
- (if;; (zerop value)
- (or (null value)
- (and (numberp value) (zerop value))) ; zzz jrd
- (princ 'b stream)
- (let ((word-width
- ;; set by a prefix instruction
- (or (sb!disassem:dstate-get-prop dstate 'word-width)
- +default-operand-size+)))
- (princ (schar (symbol-name word-width) 0) stream)))))
+ (if;; (zerop value)
+ (or (null value)
+ (and (numberp value) (zerop value))) ; zzz jrd
+ (princ 'b stream)
+ (let ((word-width
+ ;; set by a prefix instruction
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)))
+ (princ (schar (symbol-name word-width) 0) stream)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *conditions*
(let ((vec (make-array 16 :initial-element nil)))
(dolist (cond *conditions*)
(when (null (aref vec (cdr cond)))
- (setf (aref vec (cdr cond)) (car cond))))
+ (setf (aref vec (cdr cond)) (car cond))))
vec))
) ; EVAL-WHEN
(eval-when (:compile-toplevel :execute)
(defun swap-if (direction field1 separator field2)
`(:if (,direction :constant 0)
- (,field1 ,separator ,field2)
- (,field2 ,separator ,field1))))
+ (,field1 ,separator ,field2)
+ (,field2 ,separator ,field1))))
(sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
(op :field (byte 8 0))
;;; Same as simple, but with the immediate value occurring by default,
;;; and with an appropiate printer.
(sb!disassem:define-instruction-format (accum-imm 8
- :include 'simple
- :default-printer '(:name
- :tab accum ", " imm))
+ :include 'simple
+ :default-printer '(:name
+ :tab accum ", " imm))
(imm :type 'imm-data))
(sb!disassem:define-instruction-format (reg-no-width 8
- :default-printer '(:name :tab reg))
- (op :field (byte 5 3))
+ :default-printer '(:name :tab reg))
+ (op :field (byte 5 3))
(reg :field (byte 3 0) :type 'word-reg)
;; optional fields
(accum :type 'word-accum)
;;; adds a width field to reg-no-width
(sb!disassem:define-instruction-format (reg 8
- :default-printer '(:name :tab reg))
+ :default-printer '(:name :tab reg))
(op :field (byte 4 4))
(width :field (byte 1 3) :type 'width)
(reg :field (byte 3 0) :type 'reg)
(dir :field (byte 1 4)))
(sb!disassem:define-instruction-format (two-bytes 16
- :default-printer '(:name))
+ :default-printer '(:name))
(op :fields (list (byte 8 0) (byte 8 8))))
(sb!disassem:define-instruction-format (reg-reg/mem 16
- :default-printer
- `(:name :tab reg ", " reg/mem))
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
(op :field (byte 7 1))
- (width :field (byte 1 0) :type 'width)
+ (width :field (byte 1 0) :type 'width)
(reg/mem :fields (list (byte 2 14) (byte 3 8))
- :type 'reg/mem)
- (reg :field (byte 3 11) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 11) :type 'reg)
;; optional fields
(imm))
;;; same as reg-reg/mem, but with direction bit
(sb!disassem:define-instruction-format (reg-reg/mem-dir 16
- :include 'reg-reg/mem
- :default-printer
- `(:name
- :tab
- ,(swap-if 'dir 'reg/mem ", " 'reg)))
+ :include 'reg-reg/mem
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg/mem ", " 'reg)))
(op :field (byte 6 2))
(dir :field (byte 1 1)))
;;; Same as reg-rem/mem, but uses the reg field as a second op code.
(sb!disassem:define-instruction-format (reg/mem 16
- :default-printer '(:name :tab reg/mem))
+ :default-printer '(:name :tab reg/mem))
(op :fields (list (byte 7 1) (byte 3 11)))
- (width :field (byte 1 0) :type 'width)
+ (width :field (byte 1 0) :type 'width)
(reg/mem :fields (list (byte 2 14) (byte 3 8))
- :type 'sized-reg/mem)
+ :type 'sized-reg/mem)
;; optional fields
(imm))
;;; Same as reg/mem, but with the immediate value occurring by default,
;;; and with an appropiate printer.
(sb!disassem:define-instruction-format (reg/mem-imm 16
- :include 'reg/mem
- :default-printer
- '(:name :tab reg/mem ", " imm))
+ :include 'reg/mem
+ :default-printer
+ '(:name :tab reg/mem ", " imm))
(reg/mem :type 'sized-reg/mem)
(imm :type 'imm-data))
(sb!disassem:define-instruction-format
(accum-reg/mem 16
:include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
- (reg/mem :type 'reg/mem) ; don't need a size
+ (reg/mem :type 'reg/mem) ; don't need a size
(accum :type 'accum))
;;; Same as reg-reg/mem, but with a prefix of #b00001111
(sb!disassem:define-instruction-format (ext-reg-reg/mem 24
- :default-printer
- `(:name :tab reg ", " reg/mem))
- (prefix :field (byte 8 0) :value #b00001111)
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 7 9))
- (width :field (byte 1 8) :type 'width)
+ (width :field (byte 1 8) :type 'width)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'reg/mem)
- (reg :field (byte 3 19) :type 'reg)
+ :type 'reg/mem)
+ (reg :field (byte 3 19) :type 'reg)
;; optional fields
(imm))
;;; Same as reg/mem, but with a prefix of #b00001111
(sb!disassem:define-instruction-format (ext-reg/mem 24
- :default-printer '(:name :tab reg/mem))
- (prefix :field (byte 8 0) :value #b00001111)
+ :default-printer '(:name :tab reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
(op :fields (list (byte 7 9) (byte 3 19)))
- (width :field (byte 1 8) :type 'width)
+ (width :field (byte 1 8) :type 'width)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'sized-reg/mem)
+ :type 'sized-reg/mem)
;; optional fields
(imm))
(sb!disassem:define-instruction-format (ext-reg/mem-imm 24
:include 'ext-reg/mem
- :default-printer
+ :default-printer
'(:name :tab reg/mem ", " imm))
(imm :type 'imm-data))
\f
;;; regular fp inst to/from registers/memory
(sb!disassem:define-instruction-format (floating-point 16
- :default-printer
- `(:name :tab reg/mem))
+ :default-printer
+ `(:name :tab reg/mem))
(prefix :field (byte 5 3) :value #b11011)
(op :fields (list (byte 3 0) (byte 3 11)))
(reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
;;; fp insn to/from fp reg
(sb!disassem:define-instruction-format (floating-point-fp 16
- :default-printer `(:name :tab fp-reg))
+ :default-printer `(:name :tab fp-reg))
(prefix :field (byte 5 3) :value #b11011)
(suffix :field (byte 2 14) :value #b11)
(op :fields (list (byte 3 0) (byte 3 11)))
;;; (added by (?) pfw)
;;; fp no operand isns
(sb!disassem:define-instruction-format (floating-point-no 16
- :default-printer '(:name))
+ :default-printer '(:name))
(prefix :field (byte 8 0) :value #b11011001)
(suffix :field (byte 3 13) :value #b111)
(op :field (byte 5 8)))
(sb!disassem:define-instruction-format (floating-point-3 16
- :default-printer '(:name))
+ :default-printer '(:name))
(prefix :field (byte 5 3) :value #b11011)
(suffix :field (byte 2 14) :value #b11)
(op :fields (list (byte 3 0) (byte 6 8))))
(sb!disassem:define-instruction-format (floating-point-5 16
- :default-printer '(:name))
+ :default-printer '(:name))
(prefix :field (byte 8 0) :value #b11011011)
(suffix :field (byte 3 13) :value #b111)
(op :field (byte 5 8)))
(sb!disassem:define-instruction-format (floating-point-st 16
- :default-printer '(:name))
+ :default-printer '(:name))
(prefix :field (byte 8 0) :value #b11011111)
(suffix :field (byte 3 13) :value #b111)
(op :field (byte 5 8)))
(sb!disassem:define-instruction-format (string-op 8
- :include 'simple
- :default-printer '(:name width)))
+ :include 'simple
+ :default-printer '(:name width)))
(sb!disassem:define-instruction-format (short-cond-jump 16)
(op :field (byte 4 4))
- (cc :field (byte 4 0) :type 'condition-code)
+ (cc :field (byte 4 0) :type 'condition-code)
(label :field (byte 8 8) :type 'displacement))
(sb!disassem:define-instruction-format (short-jump 16
- :default-printer '(:name :tab label))
+ :default-printer '(:name :tab label))
(const :field (byte 4 4) :value #b1110)
- (op :field (byte 4 0))
+ (op :field (byte 4 0))
(label :field (byte 8 8) :type 'displacement))
(sb!disassem:define-instruction-format (near-cond-jump 16)
(op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
- (cc :field (byte 4 8) :type 'condition-code)
+ (cc :field (byte 4 8) :type 'condition-code)
;; The disassembler currently doesn't let you have an instruction > 32 bits
;; long, so we fake it by using a prefilter to read the offset.
(label :type 'displacement
- :prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate))))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
(sb!disassem:define-instruction-format (near-jump 8
- :default-printer '(:name :tab label))
+ :default-printer '(:name :tab label))
(op :field (byte 8 0))
;; The disassembler currently doesn't let you have an instruction > 32 bits
;; long, so we fake it by using a prefilter to read the address.
(label :type 'displacement
- :prefilter (lambda (value dstate)
- (declare (ignore value)) ; always nil anyway
- (sb!disassem:read-signed-suffix 32 dstate))))
+ :prefilter (lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
(sb!disassem:define-instruction-format (cond-set 24
- :default-printer '('set cc :tab reg/mem))
+ :default-printer '('set cc :tab reg/mem))
(prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 4 12) :value #b1001)
- (cc :field (byte 4 8) :type 'condition-code)
+ (cc :field (byte 4 8) :type 'condition-code)
(reg/mem :fields (list (byte 2 22) (byte 3 16))
- :type 'byte-reg/mem)
- (reg :field (byte 3 19) :value #b000))
+ :type 'byte-reg/mem)
+ (reg :field (byte 3 19) :value #b000))
(sb!disassem:define-instruction-format (cond-move 24
:default-printer
(reg :field (byte 3 19) :type 'reg))
(sb!disassem:define-instruction-format (enter-format 32
- :default-printer '(:name
- :tab disp
- (:unless (:constant 0)
- ", " level)))
+ :default-printer '(:name
+ :tab disp
+ (:unless (:constant 0)
+ ", " level)))
(op :field (byte 8 0))
(disp :field (byte 16 8))
(level :field (byte 8 24)))
(sb!disassem:define-instruction-format (prefetch 24
- :default-printer
- '(:name ", " reg/mem))
+ :default-printer
+ '(:name ", " reg/mem))
(prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 8 8) :value #b00011000)
(reg/mem :fields (list (byte 2 22) (byte 3 16)) :type 'byte-reg/mem)
;;; Single byte instruction with an immediate byte argument.
(sb!disassem:define-instruction-format (byte-imm 16
- :default-printer '(:name :tab code))
+ :default-printer '(:name :tab code))
(op :field (byte 8 0))
(code :field (byte 8 8)))
\f
(note-fixup segment :absolute fixup)
(let ((offset (fixup-offset fixup)))
(if (label-p offset)
- (emit-back-patch segment
- 4 ; FIXME: n-word-bytes
- (lambda (segment posn)
- (declare (ignore posn))
- (emit-dword segment
- (- (+ (component-header-length)
- (or (label-position offset)
- 0))
- other-pointer-lowtag))))
- (emit-dword segment (or offset 0)))))
+ (emit-back-patch segment
+ 4 ; FIXME: n-word-bytes
+ (lambda (segment posn)
+ (declare (ignore posn))
+ (emit-dword segment
+ (- (+ (component-header-length)
+ (or (label-position offset)
+ 0))
+ other-pointer-lowtag))))
+ (emit-dword segment (or offset 0)))))
(defun emit-relative-fixup (segment fixup)
(note-fixup segment :relative fixup)
(aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
(let ((offset (tn-offset tn)))
(logior (ash (logand offset 1) 2)
- (ash offset -1))))
+ (ash offset -1))))
(defstruct (ea (:constructor make-ea (size &key base index scale disp))
- (:copier nil))
+ (:copier nil))
(size nil :type (member :byte :word :dword))
(base nil :type (or tn null))
(index nil :type (or tn null))
(disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
(def!method print-object ((ea ea) stream)
(cond ((or *print-escape* *print-readably*)
- (print-unreadable-object (ea stream :type t)
- (format stream
- "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
- (ea-size ea)
- (ea-base ea)
- (ea-index ea)
- (let ((scale (ea-scale ea)))
- (if (= scale 1) nil scale))
- (ea-disp ea))))
- (t
- (format stream "~A PTR [" (symbol-name (ea-size ea)))
- (when (ea-base ea)
- (write-string (sb!c::location-print-name (ea-base ea)) stream)
- (when (ea-index ea)
- (write-string "+" stream)))
- (when (ea-index ea)
- (write-string (sb!c::location-print-name (ea-index ea)) stream))
- (unless (= (ea-scale ea) 1)
- (format stream "*~A" (ea-scale ea)))
- (typecase (ea-disp ea)
- (null)
- (integer
- (format stream "~@D" (ea-disp ea)))
- (t
- (format stream "+~A" (ea-disp ea))))
- (write-char #\] stream))))
+ (print-unreadable-object (ea stream :type t)
+ (format stream
+ "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
+ (ea-size ea)
+ (ea-base ea)
+ (ea-index ea)
+ (let ((scale (ea-scale ea)))
+ (if (= scale 1) nil scale))
+ (ea-disp ea))))
+ (t
+ (format stream "~A PTR [" (symbol-name (ea-size ea)))
+ (when (ea-base ea)
+ (write-string (sb!c::location-print-name (ea-base ea)) stream)
+ (when (ea-index ea)
+ (write-string "+" stream)))
+ (when (ea-index ea)
+ (write-string (sb!c::location-print-name (ea-index ea)) stream))
+ (unless (= (ea-scale ea) 1)
+ (format stream "*~A" (ea-scale ea)))
+ (typecase (ea-disp ea)
+ (null)
+ (integer
+ (format stream "~@D" (ea-disp ea)))
+ (t
+ (format stream "+~A" (ea-disp ea))))
+ (write-char #\] stream))))
(defun emit-ea (segment thing reg &optional allow-constants)
(etypecase thing
(tn
(ecase (sb-name (sc-sb (tn-sc thing)))
(registers
- (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
+ (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
(stack
- ;; Convert stack tns into an index off of EBP.
- (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
- (cond ((< -128 disp 127)
- (emit-mod-reg-r/m-byte segment #b01 reg #b101)
- (emit-byte segment disp))
- (t
- (emit-mod-reg-r/m-byte segment #b10 reg #b101)
- (emit-dword segment disp)))))
+ ;; Convert stack tns into an index off of EBP.
+ (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
+ (cond ((< -128 disp 127)
+ (emit-mod-reg-r/m-byte segment #b01 reg #b101)
+ (emit-byte segment disp))
+ (t
+ (emit-mod-reg-r/m-byte segment #b10 reg #b101)
+ (emit-dword segment disp)))))
(constant
- (unless allow-constants
- (error
- "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
- (emit-mod-reg-r/m-byte segment #b00 reg #b101)
- (emit-absolute-fixup segment
- (make-fixup nil
- :code-object
- (- (* (tn-offset thing) n-word-bytes)
- other-pointer-lowtag))))))
+ (unless allow-constants
+ (error
+ "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
+ (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+ (emit-absolute-fixup segment
+ (make-fixup nil
+ :code-object
+ (- (* (tn-offset thing) n-word-bytes)
+ other-pointer-lowtag))))))
(ea
(let* ((base (ea-base thing))
- (index (ea-index thing))
- (scale (ea-scale thing))
- (disp (ea-disp thing))
- (mod (cond ((or (null base)
- (and (eql disp 0)
- (not (= (reg-tn-encoding base) #b101))))
- #b00)
- ((and (fixnump disp) (<= -128 disp 127))
- #b01)
- (t
- #b10)))
- (r/m (cond (index #b100)
- ((null base) #b101)
- (t (reg-tn-encoding base)))))
+ (index (ea-index thing))
+ (scale (ea-scale thing))
+ (disp (ea-disp thing))
+ (mod (cond ((or (null base)
+ (and (eql disp 0)
+ (not (= (reg-tn-encoding base) #b101))))
+ #b00)
+ ((and (fixnump disp) (<= -128 disp 127))
+ #b01)
+ (t
+ #b10)))
+ (r/m (cond (index #b100)
+ ((null base) #b101)
+ (t (reg-tn-encoding base)))))
(emit-mod-reg-r/m-byte segment mod reg r/m)
(when (= r/m #b100)
- (let ((ss (1- (integer-length scale)))
- (index (if (null index)
- #b100
- (let ((index (reg-tn-encoding index)))
- (if (= index #b100)
- (error "can't index off of ESP")
- index))))
- (base (if (null base)
- #b101
- (reg-tn-encoding base))))
- (emit-sib-byte segment ss index base)))
+ (let ((ss (1- (integer-length scale)))
+ (index (if (null index)
+ #b100
+ (let ((index (reg-tn-encoding index)))
+ (if (= index #b100)
+ (error "can't index off of ESP")
+ index))))
+ (base (if (null base)
+ #b101
+ (reg-tn-encoding base))))
+ (emit-sib-byte segment ss index base)))
(cond ((= mod #b01)
- (emit-byte segment disp))
- ((or (= mod #b10) (null base))
- (if (fixup-p disp)
- (emit-absolute-fixup segment disp)
- (emit-dword segment disp))))))
+ (emit-byte segment disp))
+ ((or (= mod #b10) (null base))
+ (if (fixup-p disp)
+ (emit-absolute-fixup segment disp)
+ (emit-dword segment disp))))))
(fixup
(emit-mod-reg-r/m-byte segment #b00 reg #b101)
(emit-absolute-fixup segment thing))))
(defun emit-fp-op (segment thing op)
(if (fp-reg-tn-p thing)
(emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
- (byte 3 0)
- #b11000000)))
+ (byte 3 0)
+ #b11000000)))
(emit-ea segment thing op)))
(defun byte-reg-p (thing)
;; to hack up the code
(case (sc-name (tn-sc thing))
(#.*dword-sc-names*
- :dword)
+ :dword)
(#.*word-sc-names*
- :word)
+ :word)
(#.*byte-sc-names*
- :byte)
+ :byte)
;; added by jrd: float-registers is a separate size (?)
(#.*float-sc-names*
- :float)
+ :float)
(#.*double-sc-names*
- :double)
+ :double)
(t
- (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
+ (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
(ea
(ea-size thing))
(t
(defun matching-operand-size (dst src)
(let ((dst-size (operand-size dst))
- (src-size (operand-size src)))
+ (src-size (operand-size src)))
(if dst-size
- (if src-size
- (if (eq dst-size src-size)
- dst-size
- (error "size mismatch: ~S is a ~S and ~S is a ~S."
- dst dst-size src src-size))
- dst-size)
- (if src-size
- src-size
- (error "can't tell the size of either ~S or ~S" dst src)))))
+ (if src-size
+ (if (eq dst-size src-size)
+ dst-size
+ (error "size mismatch: ~S is a ~S and ~S is a ~S."
+ dst dst-size src src-size))
+ dst-size)
+ (if src-size
+ src-size
+ (error "can't tell the size of either ~S or ~S" dst src)))))
(defun emit-sized-immediate (segment size value)
(ecase size
(define-instruction mov (segment dst src)
;; immediate to register
(:printer reg ((op #b1011) (imm nil :type 'imm-data))
- '(:name :tab reg ", " imm))
+ '(:name :tab reg ", " imm))
;; absolute mem to/from accumulator
(:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
- `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
+ `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
;; register to/from register/memory
(:printer reg-reg/mem-dir ((op #b100010)))
;; immediate to register/memory
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond ((register-p dst)
- (cond ((integerp src)
- (emit-byte-with-reg segment
- (if (eq size :byte)
- #b10110
- #b10111)
- (reg-tn-encoding dst))
- (emit-sized-immediate segment size src))
- ((and (fixup-p src) (accumulator-p dst))
- (emit-byte segment
- (if (eq size :byte)
- #b10100000
- #b10100001))
- (emit-absolute-fixup segment src))
- (t
- (emit-byte segment
- (if (eq size :byte)
- #b10001010
- #b10001011))
- (emit-ea segment src (reg-tn-encoding dst) t))))
- ((and (fixup-p dst) (accumulator-p src))
- (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
- (emit-absolute-fixup segment dst))
- ((integerp src)
- (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
- (emit-ea segment dst #b000)
- (emit-sized-immediate segment size src))
- ((register-p src)
- (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
- (emit-ea segment dst (reg-tn-encoding src)))
- ((fixup-p src)
- (aver (eq size :dword))
- (emit-byte segment #b11000111)
- (emit-ea segment dst #b000)
- (emit-absolute-fixup segment src))
- (t
- (error "bogus arguments to MOV: ~S ~S" dst src))))))
+ (cond ((integerp src)
+ (emit-byte-with-reg segment
+ (if (eq size :byte)
+ #b10110
+ #b10111)
+ (reg-tn-encoding dst))
+ (emit-sized-immediate segment size src))
+ ((and (fixup-p src) (accumulator-p dst))
+ (emit-byte segment
+ (if (eq size :byte)
+ #b10100000
+ #b10100001))
+ (emit-absolute-fixup segment src))
+ (t
+ (emit-byte segment
+ (if (eq size :byte)
+ #b10001010
+ #b10001011))
+ (emit-ea segment src (reg-tn-encoding dst) t))))
+ ((and (fixup-p dst) (accumulator-p src))
+ (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
+ (emit-absolute-fixup segment dst))
+ ((integerp src)
+ (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
+ (emit-ea segment dst #b000)
+ (emit-sized-immediate segment size src))
+ ((register-p src)
+ (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
+ (emit-ea segment dst (reg-tn-encoding src)))
+ ((fixup-p src)
+ (aver (eq size :dword))
+ (emit-byte segment #b11000111)
+ (emit-ea segment dst #b000)
+ (emit-absolute-fixup segment src))
+ (t
+ (error "bogus arguments to MOV: ~S ~S" dst src))))))
(defun emit-move-with-extension (segment dst src opcode)
(aver (register-p dst))
(let ((dst-size (operand-size dst))
- (src-size (operand-size src)))
+ (src-size (operand-size src)))
(ecase dst-size
(:word
(aver (eq src-size :byte))
(emit-ea segment src (reg-tn-encoding dst)))
(:dword
(ecase src-size
- (:byte
- (maybe-emit-operand-size-prefix segment :dword)
- (emit-byte segment #b00001111)
- (emit-byte segment opcode)
- (emit-ea segment src (reg-tn-encoding dst)))
- (:word
- (emit-byte segment #b00001111)
- (emit-byte segment (logior opcode 1))
- (emit-ea segment src (reg-tn-encoding dst))))))))
+ (:byte
+ (maybe-emit-operand-size-prefix segment :dword)
+ (emit-byte segment #b00001111)
+ (emit-byte segment opcode)
+ (emit-ea segment src (reg-tn-encoding dst)))
+ (:word
+ (emit-byte segment #b00001111)
+ (emit-byte segment (logior opcode 1))
+ (emit-ea segment src (reg-tn-encoding dst))))))))
(define-instruction movsx (segment dst src)
(:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
(:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
;; immediate
(:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
- '(:name :tab imm))
+ '(:name :tab imm))
(:printer byte ((op #b01101000) (imm nil :type 'imm-word))
- '(:name :tab imm))
+ '(:name :tab imm))
;; ### segment registers?
(:emitter
(cond ((integerp src)
- (cond ((<= -128 src 127)
- (emit-byte segment #b01101010)
- (emit-byte segment src))
- (t
- (emit-byte segment #b01101000)
- (emit-dword segment src))))
- ((fixup-p src)
- ;; Interpret the fixup as an immediate dword to push.
- (emit-byte segment #b01101000)
- (emit-absolute-fixup segment src))
- (t
- (let ((size (operand-size src)))
- (aver (not (eq size :byte)))
- (maybe-emit-operand-size-prefix segment size)
- (cond ((register-p src)
- (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
- (t
- (emit-byte segment #b11111111)
- (emit-ea segment src #b110 t))))))))
+ (cond ((<= -128 src 127)
+ (emit-byte segment #b01101010)
+ (emit-byte segment src))
+ (t
+ (emit-byte segment #b01101000)
+ (emit-dword segment src))))
+ ((fixup-p src)
+ ;; Interpret the fixup as an immediate dword to push.
+ (emit-byte segment #b01101000)
+ (emit-absolute-fixup segment src))
+ (t
+ (let ((size (operand-size src)))
+ (aver (not (eq size :byte)))
+ (maybe-emit-operand-size-prefix segment size)
+ (cond ((register-p src)
+ (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
+ (t
+ (emit-byte segment #b11111111)
+ (emit-ea segment src #b110 t))))))))
(define-instruction pusha (segment)
(:printer byte ((op #b01100000)))
(aver (not (eq size :byte)))
(maybe-emit-operand-size-prefix segment size)
(cond ((register-p dst)
- (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
- (t
- (emit-byte segment #b10001111)
- (emit-ea segment dst #b000))))))
+ (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
+ (t
+ (emit-byte segment #b10001111)
+ (emit-ea segment dst #b000))))))
(define-instruction popa (segment)
(:printer byte ((op #b01100001)))
(let ((size (matching-operand-size operand1 operand2)))
(maybe-emit-operand-size-prefix segment size)
(labels ((xchg-acc-with-something (acc something)
- (if (and (not (eq size :byte)) (register-p something))
- (emit-byte-with-reg segment
- #b10010
- (reg-tn-encoding something))
- (xchg-reg-with-something acc something)))
- (xchg-reg-with-something (reg something)
- (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
- (emit-ea segment something (reg-tn-encoding reg))))
+ (if (and (not (eq size :byte)) (register-p something))
+ (emit-byte-with-reg segment
+ #b10010
+ (reg-tn-encoding something))
+ (xchg-reg-with-something acc something)))
+ (xchg-reg-with-something (reg something)
+ (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
+ (emit-ea segment something (reg-tn-encoding reg))))
(cond ((accumulator-p operand1)
- (xchg-acc-with-something operand1 operand2))
- ((accumulator-p operand2)
- (xchg-acc-with-something operand2 operand1))
- ((register-p operand1)
- (xchg-reg-with-something operand1 operand2))
- ((register-p operand2)
- (xchg-reg-with-something operand2 operand1))
- (t
- (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
+ (xchg-acc-with-something operand1 operand2))
+ ((accumulator-p operand2)
+ (xchg-acc-with-something operand2 operand1))
+ ((register-p operand1)
+ (xchg-reg-with-something operand1 operand2))
+ ((register-p operand2)
+ (xchg-reg-with-something operand2 operand1))
+ (t
+ (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
(define-instruction lea (segment dst src)
(:printer reg-reg/mem ((op #b1000110) (width 1)))
;;;; arithmetic
(defun emit-random-arith-inst (name segment dst src opcode
- &optional allow-constants)
+ &optional allow-constants)
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond
((integerp src)
(cond ((and (not (eq size :byte)) (<= -128 src 127))
- (emit-byte segment #b10000011)
- (emit-ea segment dst opcode allow-constants)
- (emit-byte segment src))
- ((accumulator-p dst)
- (emit-byte segment
- (dpb opcode
- (byte 3 3)
- (if (eq size :byte)
- #b00000100
- #b00000101)))
- (emit-sized-immediate segment size src))
- (t
- (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
- (emit-ea segment dst opcode allow-constants)
- (emit-sized-immediate segment size src))))
+ (emit-byte segment #b10000011)
+ (emit-ea segment dst opcode allow-constants)
+ (emit-byte segment src))
+ ((accumulator-p dst)
+ (emit-byte segment
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte)
+ #b00000100
+ #b00000101)))
+ (emit-sized-immediate segment size src))
+ (t
+ (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
+ (emit-ea segment dst opcode allow-constants)
+ (emit-sized-immediate segment size src))))
((register-p src)
(emit-byte segment
- (dpb opcode
- (byte 3 3)
- (if (eq size :byte) #b00000000 #b00000001)))
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000000 #b00000001)))
(emit-ea segment dst (reg-tn-encoding src) allow-constants))
((register-p dst)
(emit-byte segment
- (dpb opcode
- (byte 3 3)
- (if (eq size :byte) #b00000010 #b00000011)))
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000010 #b00000011)))
(emit-ea segment src (reg-tn-encoding dst) allow-constants))
(t
(error "bogus operands to ~A" name)))))
`((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
(reg/mem-imm ((op (#b1000000 ,subop))))
(reg/mem-imm ((op (#b1000001 ,subop))
- (imm nil :type signed-imm-byte)))
+ (imm nil :type signed-imm-byte)))
(reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
)
(let ((size (operand-size dst)))
(maybe-emit-operand-size-prefix segment size)
(cond ((and (not (eq size :byte)) (register-p dst))
- (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
- (t
- (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
- (emit-ea segment dst #b000))))))
+ (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
+ (t
+ (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+ (emit-ea segment dst #b000))))))
(define-instruction dec (segment dst)
;; Register.
(let ((size (operand-size dst)))
(maybe-emit-operand-size-prefix segment size)
(cond ((and (not (eq size :byte)) (register-p dst))
- (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
- (t
- (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
- (emit-ea segment dst #b001))))))
+ (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
+ (t
+ (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+ (emit-ea segment dst #b001))))))
(define-instruction neg (segment dst)
(:printer reg/mem ((op '(#b1111011 #b011))))
(:printer ext-reg-reg/mem ((op #b1010111)))
(:printer reg-reg/mem ((op #b0110100) (width 1)
(imm nil :type 'signed-imm-word))
- '(:name :tab reg ", " reg/mem ", " imm))
+ '(:name :tab reg ", " reg/mem ", " imm))
(:printer reg-reg/mem ((op #b0110101) (width 1)
- (imm nil :type 'signed-imm-byte))
- '(:name :tab reg ", " reg/mem ", " imm))
+ (imm nil :type 'signed-imm-byte))
+ '(:name :tab reg ", " reg/mem ", " imm))
(:emitter
(flet ((r/m-with-immed-to-reg (reg r/m immed)
- (let* ((size (matching-operand-size reg r/m))
- (sx (and (not (eq size :byte)) (<= -128 immed 127))))
- (maybe-emit-operand-size-prefix segment size)
- (emit-byte segment (if sx #b01101011 #b01101001))
- (emit-ea segment r/m (reg-tn-encoding reg))
- (if sx
- (emit-byte segment immed)
- (emit-sized-immediate segment size immed)))))
+ (let* ((size (matching-operand-size reg r/m))
+ (sx (and (not (eq size :byte)) (<= -128 immed 127))))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if sx #b01101011 #b01101001))
+ (emit-ea segment r/m (reg-tn-encoding reg))
+ (if sx
+ (emit-byte segment immed)
+ (emit-sized-immediate segment size immed)))))
(cond (src2
- (r/m-with-immed-to-reg dst src1 src2))
- (src1
- (if (integerp src1)
- (r/m-with-immed-to-reg dst dst src1)
- (let ((size (matching-operand-size dst src1)))
- (maybe-emit-operand-size-prefix segment size)
- (emit-byte segment #b00001111)
- (emit-byte segment #b10101111)
- (emit-ea segment src1 (reg-tn-encoding dst)))))
- (t
- (let ((size (operand-size dst)))
- (maybe-emit-operand-size-prefix segment size)
- (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
- (emit-ea segment dst #b101)))))))
+ (r/m-with-immed-to-reg dst src1 src2))
+ (src1
+ (if (integerp src1)
+ (r/m-with-immed-to-reg dst dst src1)
+ (let ((size (matching-operand-size dst src1)))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b10101111)
+ (emit-ea segment src1 (reg-tn-encoding dst)))))
+ (t
+ (let ((size (operand-size dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment dst #b101)))))))
(define-instruction div (segment dst src)
(:printer accum-reg/mem ((op '(#b1111011 #b110))))
(let ((size (operand-size dst)))
(maybe-emit-operand-size-prefix segment size)
(multiple-value-bind (major-opcode immed)
- (case amount
- (:cl (values #b11010010 nil))
- (1 (values #b11010000 nil))
- (t (values #b11000000 t)))
+ (case amount
+ (:cl (values #b11010010 nil))
+ (1 (values #b11010000 nil))
+ (t (values #b11000000 t)))
(emit-byte segment
- (if (eq size :byte) major-opcode (logior major-opcode 1)))
+ (if (eq size :byte) major-opcode (logior major-opcode 1)))
(emit-ea segment dst opcode)
(when immed
- (emit-byte segment amount)))))
+ (emit-byte segment amount)))))
(eval-when (:compile-toplevel :execute)
(defun shift-inst-printer-list (subop)
`((reg/mem ((op (#b1101000 ,subop)))
- (:name :tab reg/mem ", 1"))
+ (:name :tab reg/mem ", 1"))
(reg/mem ((op (#b1101001 ,subop)))
- (:name :tab reg/mem ", " 'cl))
+ (:name :tab reg/mem ", " 'cl))
(reg/mem-imm ((op (#b1100000 ,subop))
- (imm nil :type signed-imm-byte))))))
+ (imm nil :type signed-imm-byte))))))
(define-instruction rol (segment dst amount)
(:printer-list
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment #b00001111)
(emit-byte segment (dpb opcode (byte 1 3)
- (if (eq amt :cl) #b10100101 #b10100100)))
+ (if (eq amt :cl) #b10100101 #b10100100)))
#+nil
(emit-ea segment dst src)
- (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
+ (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
(unless (eq amt :cl)
(emit-byte segment amt))))
(defun double-shift-inst-printer-list (op)
`(#+nil
(ext-reg-reg/mem-imm ((op ,(logior op #b10))
- (imm nil :type signed-imm-byte)))
+ (imm nil :type signed-imm-byte)))
(ext-reg-reg/mem ((op ,(logior op #b10)))
- (:name :tab reg/mem ", " reg ", " 'cl)))))
+ (:name :tab reg/mem ", " reg ", " 'cl)))))
(define-instruction shld (segment dst src amt)
(:declare (type (or (member :cl) (mod 32)) amt))
(let ((size (matching-operand-size this that)))
(maybe-emit-operand-size-prefix segment size)
(flet ((test-immed-and-something (immed something)
- (cond ((accumulator-p something)
- (emit-byte segment
- (if (eq size :byte) #b10101000 #b10101001))
- (emit-sized-immediate segment size immed))
- (t
- (emit-byte segment
- (if (eq size :byte) #b11110110 #b11110111))
- (emit-ea segment something #b000)
- (emit-sized-immediate segment size immed))))
- (test-reg-and-something (reg something)
- (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
- (emit-ea segment something (reg-tn-encoding reg))))
+ (cond ((accumulator-p something)
+ (emit-byte segment
+ (if (eq size :byte) #b10101000 #b10101001))
+ (emit-sized-immediate segment size immed))
+ (t
+ (emit-byte segment
+ (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment something #b000)
+ (emit-sized-immediate segment size immed))))
+ (test-reg-and-something (reg something)
+ (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
+ (emit-ea segment something (reg-tn-encoding reg))))
(cond ((integerp that)
- (test-immed-and-something that this))
- ((integerp this)
- (test-immed-and-something this that))
- ((register-p this)
- (test-reg-and-something this that))
- ((register-p that)
- (test-reg-and-something that this))
- (t
- (error "bogus operands for TEST: ~S and ~S" this that)))))))
+ (test-immed-and-something that this))
+ ((integerp this)
+ (test-immed-and-something this that))
+ ((register-p this)
+ (test-reg-and-something this that))
+ ((register-p that)
+ (test-reg-and-something that this))
+ (t
+ (error "bogus operands for TEST: ~S and ~S" this that)))))))
(define-instruction or (segment dst src)
(:printer-list
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment #b00001111)
(cond ((integerp index)
- (emit-byte segment #b10111010)
- (emit-ea segment src opcode)
- (emit-byte segment index))
- (t
- (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
- (emit-ea segment src (reg-tn-encoding index))))))
+ (emit-byte segment #b10111010)
+ (emit-ea segment src opcode)
+ (emit-byte segment index))
+ (t
+ (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
+ (emit-ea segment src (reg-tn-encoding index))))))
(eval-when (:compile-toplevel :execute)
(defun bit-test-inst-printer-list (subop)
(label
(emit-byte segment #b11101000)
(emit-back-patch segment
- 4
- (lambda (segment posn)
- (emit-dword segment
- (- (label-position where)
- (+ posn 4))))))
+ 4
+ (lambda (segment posn)
+ (emit-dword segment
+ (- (label-position where)
+ (+ posn 4))))))
(fixup
(emit-byte segment #b11101000)
(emit-relative-fixup segment where))
(defun emit-byte-displacement-backpatch (segment target)
(emit-back-patch segment
- 1
- (lambda (segment posn)
- (let ((disp (- (label-position target) (1+ posn))))
- (aver (<= -128 disp 127))
- (emit-byte segment disp)))))
+ 1
+ (lambda (segment posn)
+ (let ((disp (- (label-position target) (1+ posn))))
+ (aver (<= -128 disp 127))
+ (emit-byte segment disp)))))
(define-instruction jmp (segment cond &optional where)
;; conditional jumps
(:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
(:emitter
(cond (where
- (emit-chooser
- segment 6 2
- (lambda (segment posn delta-if-after)
- (let ((disp (- (label-position where posn delta-if-after)
- (+ posn 2))))
- (when (<= -128 disp 127)
- (emit-byte segment
- (dpb (conditional-opcode cond)
- (byte 4 0)
- #b01110000))
- (emit-byte-displacement-backpatch segment where)
- t)))
- (lambda (segment posn)
- (let ((disp (- (label-position where) (+ posn 6))))
- (emit-byte segment #b00001111)
- (emit-byte segment
- (dpb (conditional-opcode cond)
- (byte 4 0)
- #b10000000))
- (emit-dword segment disp)))))
- ((label-p (setq where cond))
- (emit-chooser
- segment 5 0
- (lambda (segment posn delta-if-after)
- (let ((disp (- (label-position where posn delta-if-after)
- (+ posn 2))))
- (when (<= -128 disp 127)
- (emit-byte segment #b11101011)
- (emit-byte-displacement-backpatch segment where)
- t)))
- (lambda (segment posn)
- (let ((disp (- (label-position where) (+ posn 5))))
- (emit-byte segment #b11101001)
- (emit-dword segment disp)))))
- ((fixup-p where)
- (emit-byte segment #b11101001)
- (emit-relative-fixup segment where))
- (t
- (unless (or (ea-p where) (tn-p where))
- (error "don't know what to do with ~A" where))
- (emit-byte segment #b11111111)
- (emit-ea segment where #b100)))))
+ (emit-chooser
+ segment 6 2
+ (lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
+ (emit-byte segment
+ (dpb (conditional-opcode cond)
+ (byte 4 0)
+ #b01110000))
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ (lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 6))))
+ (emit-byte segment #b00001111)
+ (emit-byte segment
+ (dpb (conditional-opcode cond)
+ (byte 4 0)
+ #b10000000))
+ (emit-dword segment disp)))))
+ ((label-p (setq where cond))
+ (emit-chooser
+ segment 5 0
+ (lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
+ (emit-byte segment #b11101011)
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ (lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 5))))
+ (emit-byte segment #b11101001)
+ (emit-dword segment disp)))))
+ ((fixup-p where)
+ (emit-byte segment #b11101001)
+ (emit-relative-fixup segment where))
+ (t
+ (unless (or (ea-p where) (tn-p where))
+ (error "don't know what to do with ~A" where))
+ (emit-byte segment #b11111111)
+ (emit-ea segment where #b100)))))
(define-instruction jmp-short (segment label)
(:emitter
(define-instruction ret (segment &optional stack-delta)
(:printer byte ((op #b11000011)))
(:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
- '(:name :tab imm))
+ '(:name :tab imm))
(:emitter
(cond (stack-delta
- (emit-byte segment #b11000010)
- (emit-word segment stack-delta))
- (t
- (emit-byte segment #b11000011)))))
+ (emit-byte segment #b11000010)
+ (emit-word segment stack-delta))
+ (t
+ (emit-byte segment #b11000011)))))
(define-instruction jecxz (segment target)
(:printer short-jump ((op #b0011)))
(define-instruction loop (segment target)
(:printer short-jump ((op #b0010)))
(:emitter
- (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
+ (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
(emit-byte-displacement-backpatch segment target)))
(define-instruction loopz (segment target)
(define-instruction enter (segment disp &optional (level 0))
(:declare (type (unsigned-byte 16) disp)
- (type (unsigned-byte 8) level))
+ (type (unsigned-byte 8) level))
(:printer enter-format ((op #b11001000)))
(:emitter
(emit-byte segment #b11001000)
(defun snarf-error-junk (sap offset &optional length-only)
(let* ((length (sb!sys:sap-ref-8 sap offset))
- (vector (make-array length :element-type '(unsigned-byte 8))))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
(declare (type sb!sys:system-area-pointer sap)
- (type (unsigned-byte 8) length)
- (type (simple-array (unsigned-byte 8) (*)) vector))
+ (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
(cond (length-only
- (values 0 (1+ length) nil nil))
- (t
- (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
+ (values 0 (1+ length) nil nil))
+ (t
+ (sb!kernel:copy-ub8-from-system-area sap (1+ offset)
vector 0 length)
- (collect ((sc-offsets)
- (lengths))
- (lengths 1) ; the length byte
- (let* ((index 0)
- (error-number (sb!c:read-var-integer vector index)))
- (lengths index)
- (loop
- (when (>= index length)
- (return))
- (let ((old-index index))
- (sc-offsets (sb!c:read-var-integer vector index))
- (lengths (- index old-index))))
- (values error-number
- (1+ length)
- (sc-offsets)
- (lengths))))))))
+ (collect ((sc-offsets)
+ (lengths))
+ (lengths 1) ; the length byte
+ (let* ((index 0)
+ (error-number (sb!c:read-var-integer vector index)))
+ (lengths index)
+ (loop
+ (when (>= index length)
+ (return))
+ (let ((old-index index))
+ (sc-offsets (sb!c:read-var-integer vector index))
+ (lengths (- index old-index))))
+ (values error-number
+ (1+ length)
+ (sc-offsets)
+ (lengths))))))))
#|
(defmacro break-cases (breaknum &body cases)
(let ((bn-temp (gensym)))
(collect ((clauses))
(dolist (case cases)
- (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
+ (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
`(let ((,bn-temp ,breaknum))
- (cond ,@(clauses))))))
+ (cond ,@(clauses))))))
|#
(defun break-control (chunk inst stream dstate)
(define-instruction break (segment code)
(:declare (type (unsigned-byte 8) code))
(:printer byte-imm ((op #b11001100)) '(:name :tab code)
- :control #'break-control)
+ :control #'break-control)
(:emitter
(emit-byte segment #b11001100)
(emit-byte segment code)))
(defun emit-header-data (segment type)
(emit-back-patch segment
- 4
- (lambda (segment posn)
- (emit-dword segment
- (logior type
- (ash (+ posn
- (component-header-length))
- (- n-widetag-bits
- word-shift)))))))
+ 4
+ (lambda (segment posn)
+ (emit-dword segment
+ (logior type
+ (ash (+ posn
+ (component-header-length))
+ (- n-widetag-bits
+ word-shift)))))))
(define-instruction simple-fun-header-word (segment)
(:emitter
(:printer floating-point ((op '(#b001 #b010))))
(:emitter
(cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b010))
- (t
- (emit-byte segment #b11011001)
- (emit-fp-op segment dest #b010)))))
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b010))
+ (t
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment dest #b010)))))
;;; Store double from st(0).
(define-instruction fstd (segment dest)
(:printer floating-point-fp ((op '(#b101 #b010))))
(:emitter
(cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b010))
- (t
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b010)))))
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b010))
+ (t
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b010)))))
;;; Arithmetic ops are all done with at least one operand at top of
;;; stack. The other operand is is another register or a 32/64 bit
(:printer floating-point-fp ((op '(#b001 #b001))))
(:emitter
(unless (and (tn-p source)
- (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
+ (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
(cl:break))
(emit-byte segment #b11011001)
(emit-fp-op segment source #b001)))
(:printer floating-point ((op '(#b001 #b011))))
(:emitter
(cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b011))
- (t
- (emit-byte segment #b11011001)
- (emit-fp-op segment dest #b011)))))
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b011))
+ (t
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment dest #b011)))))
;;; Store double from st(0) and pop.
(define-instruction fstpd (segment dest)
(:printer floating-point-fp ((op '(#b101 #b011))))
(:emitter
(cond ((fp-reg-tn-p dest)
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b011))
- (t
- (emit-byte segment #b11011101)
- (emit-fp-op segment dest #b011)))))
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b011))
+ (t
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b011)))))
;;; Store long from st(0) and pop.
(define-instruction fstpl (segment dest)
;;; in any VOPs that use them. See the book.
;;; st0 <- st1*log2(st0)
-(define-instruction fyl2x(segment) ; pops stack
+(define-instruction fyl2x(segment) ; pops stack
(:printer floating-point-no ((op #b10001)))
(:emitter
(emit-byte segment #b11011001)
(emit-byte segment #b11011001)
(emit-byte segment #b11110000)))
-(define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
+(define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
(:printer floating-point-no ((op #b10010)))
(:emitter
(emit-byte segment #b11011001)
(emit-byte segment #b11110010)))
-(define-instruction fpatan(segment) ; POPS STACK
+(define-instruction fpatan(segment) ; POPS STACK
(:printer floating-point-no ((op #b10011)))
(:emitter
(emit-byte segment #b11011001)
(inst fstp ,tn)
,@body
(unless (zerop (tn-offset ,tn))
- (inst fxch ,tn)))) ; save into new dest and restore st(0)
+ (inst fxch ,tn)))) ; save into new dest and restore st(0)
\f
;;;; instruction-like macros
#!+sb-doc
"Move SRC into DST unless they are location=."
(once-only ((n-dst dst)
- (n-src src))
+ (n-src src))
`(unless (location= ,n-dst ,n-src)
(inst mov ,n-dst ,n-src))))
(defmacro load-symbol-value (reg symbol)
`(inst mov ,reg
- (make-ea :dword
- :disp (+ nil-value
- (static-symbol-offset ',symbol)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))))
+ (make-ea :dword
+ :disp (+ nil-value
+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))))
(defmacro store-symbol-value (reg symbol)
`(inst mov
- (make-ea :dword
- :disp (+ nil-value
- (static-symbol-offset ',symbol)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))
- ,reg))
+ (make-ea :dword
+ :disp (+ nil-value
+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
+ ,reg))
#!+sb-thread
(defmacro load-tl-symbol-value (reg symbol)
(inst mov ,reg
(make-ea :dword
:disp (+ nil-value
- (static-symbol-offset ',symbol)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
(inst fs-segment-prefix)
(inst mov ,reg (make-ea :dword :scale 1 :index ,reg))))
#!-sb-thread
(inst mov ,temp
(make-ea :dword
:disp (+ nil-value
- (static-symbol-offset ',symbol)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
(inst fs-segment-prefix)
(inst mov (make-ea :dword :scale 1 :index ,temp) ,reg)))
#!-sb-thread
(defmacro store-tl-symbol-value (reg symbol temp)
(declare (ignore temp))
`(store-symbol-value ,reg ,symbol))
-
+
(defmacro load-type (target source &optional (offset 0))
#!+sb-doc
"Loads the type bits of a pointer into target independent of
byte-ordering issues."
(once-only ((n-target target)
- (n-source source)
- (n-offset offset))
+ (n-source source)
+ (n-offset offset))
(ecase *backend-byte-order*
(:little-endian
`(inst mov ,n-target
- (make-ea :byte :base ,n-source :disp ,n-offset)))
+ (make-ea :byte :base ,n-source :disp ,n-offset)))
(:big-endian
`(inst mov ,n-target
- (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
+ (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
\f
;;;; allocation helpers
(defun allocation-notinline (alloc-tn size)
(let* ((alloc-tn-offset (tn-offset alloc-tn))
- ;; C call to allocate via dispatch routines. Each
- ;; destination has a special entry point. The size may be a
- ;; register or a constant.
- (tn-text (ecase alloc-tn-offset
- (#.eax-offset "eax")
- (#.ecx-offset "ecx")
- (#.edx-offset "edx")
- (#.ebx-offset "ebx")
- (#.esi-offset "esi")
- (#.edi-offset "edi")))
- (size-text (case size (8 "8_") (16 "16_") (t ""))))
+ ;; C call to allocate via dispatch routines. Each
+ ;; destination has a special entry point. The size may be a
+ ;; register or a constant.
+ (tn-text (ecase alloc-tn-offset
+ (#.eax-offset "eax")
+ (#.ecx-offset "ecx")
+ (#.edx-offset "edx")
+ (#.ebx-offset "ebx")
+ (#.esi-offset "esi")
+ (#.edi-offset "edi")))
+ (size-text (case size (8 "8_") (16 "16_") (t ""))))
(unless (or (eql size 8) (eql size 16))
(unless (and (tn-p size) (location= alloc-tn size))
- (inst mov alloc-tn size)))
+ (inst mov alloc-tn size)))
(inst call (make-fixup (concatenate 'string
- "alloc_" size-text
- "to_" tn-text)
- :foreign))))
+ "alloc_" size-text
+ "to_" tn-text)
+ :foreign))))
(defun allocation-inline (alloc-tn size)
(let ((ok (gen-label))
- (free-pointer
- (make-ea :dword :disp
- #!+sb-thread (* n-word-bytes thread-alloc-region-slot)
- #!-sb-thread (make-fixup "boxed_region" :foreign)
- :scale 1)) ; thread->alloc_region.free_pointer
- (end-addr
- (make-ea :dword :disp
- #!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot))
- #!-sb-thread (make-fixup "boxed_region" :foreign 4)
- :scale 1))) ; thread->alloc_region.end_addr
+ (free-pointer
+ (make-ea :dword :disp
+ #!+sb-thread (* n-word-bytes thread-alloc-region-slot)
+ #!-sb-thread (make-fixup "boxed_region" :foreign)
+ :scale 1)) ; thread->alloc_region.free_pointer
+ (end-addr
+ (make-ea :dword :disp
+ #!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot))
+ #!-sb-thread (make-fixup "boxed_region" :foreign 4)
+ :scale 1))) ; thread->alloc_region.end_addr
(unless (and (tn-p size) (location= alloc-tn size))
(inst mov alloc-tn size))
#!+sb-thread (inst fs-segment-prefix)
(inst cmp alloc-tn end-addr)
(inst jmp :be OK)
(let ((dst (ecase (tn-offset alloc-tn)
- (#.eax-offset "alloc_overflow_eax")
- (#.ecx-offset "alloc_overflow_ecx")
- (#.edx-offset "alloc_overflow_edx")
- (#.ebx-offset "alloc_overflow_ebx")
- (#.esi-offset "alloc_overflow_esi")
- (#.edi-offset "alloc_overflow_edi"))))
+ (#.eax-offset "alloc_overflow_eax")
+ (#.ecx-offset "alloc_overflow_ecx")
+ (#.edx-offset "alloc_overflow_edx")
+ (#.ebx-offset "alloc_overflow_ebx")
+ (#.esi-offset "alloc_overflow_esi")
+ (#.edi-offset "alloc_overflow_edi"))))
(inst call (make-fixup dst :foreign)))
(emit-label ok)
#!+sb-thread (inst fs-segment-prefix)
;; a bit of a KLUDGE, really. -- CSR, 2004-08-05 (following
;; observations made by ASF and Juho Snellman)
((and (member :inline-allocation-is-good *backend-subfeatures*)
- (or (null inline) (policy inline (>= speed space))))
+ (or (null inline) (policy inline (>= speed space))))
(allocation-inline alloc-tn size))
(t (allocation-notinline alloc-tn size)))
(values))
;;; header having the specified WIDETAG value. The result is placed in
;;; RESULT-TN.
(defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
- &body forms)
+ &body forms)
(unless forms
(bug "empty &body in WITH-FIXED-ALLOCATION"))
(once-only ((result-tn result-tn) (size size))
`(pseudo-atomic
(allocation ,result-tn (pad-data-block ,size) ,inline)
(storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
- ,result-tn)
+ ,result-tn)
(inst lea ,result-tn
- (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
+ (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
,@forms)))
\f
;;;; error code
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
- `((inst int 3) ; i386 breakpoint instruction
- ;; The return PC points here; note the location for the debugger.
- (let ((vop ,vop))
- (when vop
- (note-this-location vop :internal-error)))
- (inst byte ,kind) ; eg trap_Xyyy
- (with-adjustable-vector (,vector) ; interr arguments
- (write-var-integer (error-number-or-lose ',code) ,vector)
- ,@(mapcar (lambda (tn)
- `(let ((tn ,tn))
- ;; classic CMU CL comment:
- ;; zzzzz jrd here. tn-offset is zero for constant
- ;; tns.
- (write-var-integer (make-sc-offset (sc-number
- (tn-sc tn))
- (or (tn-offset tn)
- 0))
- ,vector)))
- values)
- (inst byte (length ,vector))
- (dotimes (i (length ,vector))
- (inst byte (aref ,vector i))))))))
+ `((inst int 3) ; i386 breakpoint instruction
+ ;; The return PC points here; note the location for the debugger.
+ (let ((vop ,vop))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst byte ,kind) ; eg trap_Xyyy
+ (with-adjustable-vector (,vector) ; interr arguments
+ (write-var-integer (error-number-or-lose ',code) ,vector)
+ ,@(mapcar (lambda (tn)
+ `(let ((tn ,tn))
+ ;; classic CMU CL comment:
+ ;; zzzzz jrd here. tn-offset is zero for constant
+ ;; tns.
+ (write-var-integer (make-sc-offset (sc-number
+ (tn-sc tn))
+ (or (tn-offset tn)
+ 0))
+ ,vector)))
+ values)
+ (inst byte (length ,vector))
+ (dotimes (i (length ,vector))
+ (inst byte (aref ,vector i))))))))
(defmacro error-call (vop error-code &rest values)
#!+sb-doc
"Cause an error. ERROR-CODE is the error to cause."
(cons 'progn
- (emit-error-break vop error-trap error-code values)))
+ (emit-error-break vop error-trap error-code values)))
(defmacro generate-error-code (vop error-code &rest values)
#!+sb-doc
;;; around. It's an operation which the AOP weenies would describe as
;;; having "cross-cutting concerns", meaning it appears all over the
;;; place and there's no logical single place to attach documentation.
-;;; grep (mostly in src/runtime) is your friend
+;;; grep (mostly in src/runtime) is your friend
;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
;;; KLUDGE: since the stack on the x86 is treated conservatively, it
;;; does not matter whether a signal occurs during construction of a
;;; dynamic-extent object, as the half-finished construction of the
-;;; object will not cause any difficulty. We can therefore elide
+;;; object will not cause any difficulty. We can therefore elide
(defmacro maybe-pseudo-atomic (really-p &body forms)
`(if ,really-p
(progn ,@forms)
`(progn
(define-vop (,name)
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types ,type tagged-num)
(:results (value :scs ,scs))
(:result-types ,el-type)
- (:generator 3 ; pw was 5
- (inst mov value (make-ea :dword :base object :index index
- :disp (- (* ,offset n-word-bytes)
- ,lowtag)))))
+ (:generator 3 ; pw was 5
+ (inst mov value (make-ea :dword :base object :index index
+ :disp (- (* ,offset n-word-bytes)
+ ,lowtag)))))
(define-vop (,(symbolicate name "-C"))
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:info index)
(:arg-types ,type (:constant (signed-byte 30)))
(:results (value :scs ,scs))
(:result-types ,el-type)
- (:generator 2 ; pw was 5
- (inst mov value (make-ea :dword :base object
- :disp (- (* (+ ,offset index) n-word-bytes)
- ,lowtag)))))))
+ (:generator 2 ; pw was 5
+ (inst mov value (make-ea :dword :base object
+ :disp (- (* (+ ,offset index) n-word-bytes)
+ ,lowtag)))))))
(defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
`(progn
(define-vop (,name)
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs ,scs :target result))
+ (index :scs (any-reg))
+ (value :scs ,scs :target result))
(:arg-types ,type tagged-num ,el-type)
(:results (result :scs ,scs))
(:result-types ,el-type)
- (:generator 4 ; was 5
- (inst mov (make-ea :dword :base object :index index
- :disp (- (* ,offset n-word-bytes) ,lowtag))
- value)
- (move result value)))
+ (:generator 4 ; was 5
+ (inst mov (make-ea :dword :base object :index index
+ :disp (- (* ,offset n-word-bytes) ,lowtag))
+ value)
+ (move result value)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs ,scs :target result))
+ (value :scs ,scs :target result))
(:info index)
(:arg-types ,type (:constant (signed-byte 30)) ,el-type)
(:results (result :scs ,scs))
(:result-types ,el-type)
- (:generator 3 ; was 5
- (inst mov (make-ea :dword :base object
- :disp (- (* (+ ,offset index) n-word-bytes)
- ,lowtag))
- value)
- (move result value)))))
+ (:generator 3 ; was 5
+ (inst mov (make-ea :dword :base object
+ :disp (- (* (+ ,offset index) n-word-bytes)
+ ,lowtag))
+ value)
+ (move result value)))))
;;; helper for alien stuff.
(defmacro with-pinned-objects ((&rest objects) &body body)
garbage collection"
`(multiple-value-prog1
(progn
- ,@(loop for p in objects
- collect `(push-word-on-c-stack
- (int-sap (sb!kernel:get-lisp-obj-address ,p))))
- ,@body)
+ ,@(loop for p in objects
+ collect `(push-word-on-c-stack
+ (int-sap (sb!kernel:get-lisp-obj-address ,p))))
+ ,@body)
;; If the body returned normally, we should restore the stack pointer
;; for the benefit of any following code in the same function. If
;; there's a non-local exit in the body, sp is garbage anyway and
(loadw value object offset lowtag)))
(define-vop (cell-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
+ (value :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 4
(storew value object offset lowtag)))
(define-vop (cell-setf)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg) :target result))
+ (value :scs (descriptor-reg any-reg) :target result))
(:results (result :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
(move result value)))
(define-vop (cell-setf-fun)
(:args (value :scs (descriptor-reg any-reg) :target result)
- (object :scs (descriptor-reg)))
+ (object :scs (descriptor-reg)))
(:results (result :scs (descriptor-reg any-reg)))
(:variant-vars offset lowtag)
(:policy :fast-safe)
;;; name is NIL, then that operation isn't defined. If the translate
;;; function is null, then we don't define a translation.
(defmacro define-cell-accessors (offset lowtag
- ref-op ref-trans set-op set-trans)
+ ref-op ref-trans set-op set-trans)
`(progn
,@(when ref-op
- `((define-vop (,ref-op cell-ref)
- (:variant ,offset ,lowtag)
- ,@(when ref-trans
- `((:translate ,ref-trans))))))
+ `((define-vop (,ref-op cell-ref)
+ (:variant ,offset ,lowtag)
+ ,@(when ref-trans
+ `((:translate ,ref-trans))))))
,@(when set-op
- `((define-vop (,set-op cell-setf)
- (:variant ,offset ,lowtag)
- ,@(when set-trans
- `((:translate ,set-trans))))))))
+ `((define-vop (,set-op cell-setf)
+ (:variant ,offset ,lowtag)
+ ,@(when set-trans
+ `((:translate ,set-trans))))))))
;;; X86 special
(define-vop (cell-xadd)
(:args (object :scs (descriptor-reg) :to :result)
- (value :scs (any-reg) :target result))
+ (value :scs (any-reg) :target result))
(:results (result :scs (any-reg) :from (:argument 1)))
(:result-types tagged-num)
(:variant-vars offset lowtag)
(:generator 4
(move result value)
(inst xadd (make-ea :dword :base object
- :disp (- (* offset n-word-bytes) lowtag))
- value)))
+ :disp (- (* offset n-word-bytes) lowtag))
+ value)))
;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF,
;;; where the offset is constant at compile time, but varies for
(loadw value object (+ base offset) lowtag)))
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg immediate)))
+ (value :scs (descriptor-reg any-reg immediate)))
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(if (sc-is value immediate)
- (let ((val (tn-value value)))
- (etypecase val
- (integer
- (inst mov
- (make-ea :dword :base object
- :disp (- (* (+ base offset) n-word-bytes) lowtag))
- (fixnumize val)))
- (symbol
- (inst mov
- (make-ea :dword :base object
- :disp (- (* (+ base offset) n-word-bytes) lowtag))
- (+ nil-value (static-symbol-offset val))))
- (character
- (inst mov
- (make-ea :dword :base object
- :disp (- (* (+ base offset) n-word-bytes) lowtag))
- (logior (ash (char-code val) n-widetag-bits)
- character-widetag)))))
- ;; Else, value not immediate.
- (storew value object (+ base offset) lowtag))))
+ (let ((val (tn-value value)))
+ (etypecase val
+ (integer
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* (+ base offset) n-word-bytes) lowtag))
+ (fixnumize val)))
+ (symbol
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* (+ base offset) n-word-bytes) lowtag))
+ (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* (+ base offset) n-word-bytes) lowtag))
+ (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)))))
+ ;; Else, value not immediate.
+ (storew value object (+ base offset) lowtag))))
(define-vop (slot-set-conditional)
(:args (object :scs (descriptor-reg) :to :eval)
- (old-value :scs (descriptor-reg any-reg) :target eax)
- (new-value :scs (descriptor-reg any-reg) :target temp))
+ (old-value :scs (descriptor-reg any-reg) :target eax)
+ (new-value :scs (descriptor-reg any-reg) :target temp))
(:temporary (:sc descriptor-reg :offset eax-offset
- :from (:argument 1) :to :result :target result) eax)
+ :from (:argument 1) :to :result :target result) eax)
(:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp)
(:variant-vars base lowtag)
(:results (result :scs (descriptor-reg)))
(move eax old-value)
(move temp new-value)
(inst cmpxchg (make-ea :dword :base object
- :disp (- (* (+ base offset) n-word-bytes) lowtag))
- temp)
+ :disp (- (* (+ base offset) n-word-bytes) lowtag))
+ temp)
(move result eax)))
;;; X86 special
(define-vop (slot-xadd)
(:args (object :scs (descriptor-reg) :to :result)
- (value :scs (any-reg) :target result))
+ (value :scs (any-reg) :target result))
(:results (result :scs (any-reg) :from (:argument 1)))
(:result-types tagged-num)
(:variant-vars base lowtag)
(:generator 4
(move result value)
(inst xadd (make-ea :dword :base object
- :disp (- (* (+ base offset) n-word-bytes) lowtag))
- value)))
+ :disp (- (* (+ base offset) n-word-bytes) lowtag))
+ value)))
(etypecase val
(integer
(if (zerop val)
- (inst xor y y)
- (inst mov y (fixnumize val))))
+ (inst xor y y)
+ (inst mov y (fixnumize val))))
(symbol
(load-symbol y val))
(character
(inst mov y (logior (ash (char-code val) n-widetag-bits)
- character-widetag))))))
+ character-widetag))))))
(define-move-fun (load-number 1) (vop x y)
((immediate) (signed-reg unsigned-reg))
;;;; the MOVE VOP
(define-vop (move)
(:args (x :scs (any-reg descriptor-reg immediate) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (any-reg descriptor-reg)
- :load-if
- (not (or (location= x y)
- (and (sc-is x any-reg descriptor-reg immediate)
- (sc-is y control-stack))))))
+ :load-if
+ (not (or (location= x y)
+ (and (sc-is x any-reg descriptor-reg immediate)
+ (sc-is y control-stack))))))
(:effects)
(:affected)
(:generator 0
(if (and (sc-is x immediate)
- (sc-is y any-reg descriptor-reg control-stack))
- (let ((val (tn-value x)))
- (etypecase val
- (integer
- (if (and (zerop val) (sc-is y any-reg descriptor-reg))
- (inst xor y y)
- (inst mov y (fixnumize val))))
- (symbol
- (inst mov y (+ nil-value (static-symbol-offset val))))
- (character
- (inst mov y (logior (ash (char-code val) n-widetag-bits)
- character-widetag)))))
+ (sc-is y any-reg descriptor-reg control-stack))
+ (let ((val (tn-value x)))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+ (inst xor y y)
+ (inst mov y (fixnumize val))))
+ (symbol
+ (inst mov y (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst mov y (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)))))
(move y x))))
(define-move-vop move :move
;;; this case the loading works out.
(define-vop (move-arg)
(:args (x :scs (any-reg descriptor-reg immediate) :target y
- :load-if (not (and (sc-is y any-reg descriptor-reg)
- (sc-is x control-stack))))
- (fp :scs (any-reg)
- :load-if (not (sc-is y any-reg descriptor-reg))))
+ :load-if (not (and (sc-is y any-reg descriptor-reg)
+ (sc-is x control-stack))))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y any-reg descriptor-reg))))
(:results (y))
(:generator 0
(sc-case y
((any-reg descriptor-reg)
(if (sc-is x immediate)
- (let ((val (tn-value x)))
- (etypecase val
- (integer
- (if (zerop val)
- (inst xor y y)
- (inst mov y (fixnumize val))))
- (symbol
- (load-symbol y val))
- (character
- (inst mov y (logior (ash (char-code val) n-widetag-bits)
- character-widetag)))))
- (move y x)))
+ (let ((val (tn-value x)))
+ (etypecase val
+ (integer
+ (if (zerop val)
+ (inst xor y y)
+ (inst mov y (fixnumize val))))
+ (symbol
+ (load-symbol y val))
+ (character
+ (inst mov y (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)))))
+ (move y x)))
((control-stack)
(if (sc-is x immediate)
- (let ((val (tn-value x)))
- (if (= (tn-offset fp) esp-offset)
- ;; C-call
- (etypecase val
- (integer
- (storew (fixnumize val) fp (tn-offset y)))
- (symbol
- (storew (+ nil-value (static-symbol-offset val))
- fp (tn-offset y)))
- (character
- (storew (logior (ash (char-code val) n-widetag-bits)
- character-widetag)
- fp (tn-offset y))))
- ;; Lisp stack
- (etypecase val
- (integer
- (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
- (symbol
- (storew (+ nil-value (static-symbol-offset val))
- fp (- (1+ (tn-offset y)))))
- (character
- (storew (logior (ash (char-code val) n-widetag-bits)
- character-widetag)
- fp (- (1+ (tn-offset y))))))))
- (if (= (tn-offset fp) esp-offset)
- ;; C-call
- (storew x fp (tn-offset y))
- ;; Lisp stack
- (storew x fp (- (1+ (tn-offset y))))))))))
+ (let ((val (tn-value x)))
+ (if (= (tn-offset fp) esp-offset)
+ ;; C-call
+ (etypecase val
+ (integer
+ (storew (fixnumize val) fp (tn-offset y)))
+ (symbol
+ (storew (+ nil-value (static-symbol-offset val))
+ fp (tn-offset y)))
+ (character
+ (storew (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)
+ fp (tn-offset y))))
+ ;; Lisp stack
+ (etypecase val
+ (integer
+ (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
+ (symbol
+ (storew (+ nil-value (static-symbol-offset val))
+ fp (- (1+ (tn-offset y)))))
+ (character
+ (storew (logior (ash (char-code val) n-widetag-bits)
+ character-widetag)
+ fp (- (1+ (tn-offset y))))))))
+ (if (= (tn-offset fp) esp-offset)
+ ;; C-call
+ (storew x fp (tn-offset y))
+ ;; Lisp stack
+ (storew x fp (- (1+ (tn-offset y))))))))))
(define-move-vop move-arg :move-arg
(any-reg descriptor-reg)
;;; possible bignum arg SCs.
(define-vop (move-to-word/fixnum)
(:args (x :scs (any-reg descriptor-reg) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (signed-reg unsigned-reg)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:arg-types tagged-num)
(:note "fixnum untagging")
(:generator 1
(:results (y :scs (signed-reg unsigned-reg)))
(:note "integer to untagged word coercion")
(:temporary (:sc unsigned-reg :offset eax-offset
- :from (:argument 0) :to (:result 0) :target y) eax)
+ :from (:argument 0) :to (:result 0) :target y) eax)
(:generator 4
(move eax x)
(inst test al-tn 3)
;;; restriction because of the control-stack ambiguity noted above.
(define-vop (move-from-word/fixnum)
(:args (x :scs (signed-reg unsigned-reg) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (any-reg descriptor-reg)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:result-types tagged-num)
(:note "fixnum tagging")
(:generator 1
(cond ((and (sc-is x signed-reg unsigned-reg)
- (not (location= x y)))
- ;; Uses 7 bytes, but faster on the Pentium
- (inst lea y (make-ea :dword :index x :scale 4)))
- (t
- ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
- (move y x)
- (inst shl y 2)))))
+ (not (location= x y)))
+ ;; Uses 7 bytes, but faster on the Pentium
+ (inst lea y (make-ea :dword :index x :scale 4)))
+ (t
+ ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
+ (move y x)
+ (inst shl y 2)))))
(define-move-vop move-from-word/fixnum :move
(signed-reg unsigned-reg) (any-reg descriptor-reg))
(:args (x :scs (signed-reg unsigned-reg) :target eax))
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax)
(:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y)
- ebx)
+ ebx)
(:temporary (:sc unsigned-reg :offset ecx-offset
- :from (:argument 0) :to (:result 0)) ecx)
+ :from (:argument 0) :to (:result 0)) ecx)
(:ignore ecx)
(:results (y :scs (any-reg descriptor-reg)))
(:note "signed word to integer coercion")
(:generator 20
(aver (not (location= x y)))
(let ((bignum (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst mov y x)
(inst shl y 1)
(inst jmp :o bignum)
;; emit-label done
(assemble (*elsewhere*)
- (emit-label bignum)
- (with-fixed-allocation
- (y bignum-widetag (+ bignum-digits-offset 1) node)
- (storew x y bignum-digits-offset other-pointer-lowtag))
- (inst jmp done)))))
+ (emit-label bignum)
+ (with-fixed-allocation
+ (y bignum-widetag (+ bignum-digits-offset 1) node)
+ (storew x y bignum-digits-offset other-pointer-lowtag))
+ (inst jmp done)))))
(define-move-vop move-from-signed :move
(signed-reg) (descriptor-reg))
(:args (x :scs (signed-reg unsigned-reg) :target eax))
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax)
(:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y)
- ebx)
+ ebx)
(:temporary (:sc unsigned-reg :offset ecx-offset
- :from (:argument 0) :to (:result 0)) ecx)
+ :from (:argument 0) :to (:result 0)) ecx)
(:ignore ecx)
(:results (y :scs (any-reg descriptor-reg)))
(:note "unsigned word to integer coercion")
(aver (not (location= x alloc)))
(aver (not (location= y alloc)))
(let ((bignum (gen-label))
- (done (gen-label))
- (one-word-bignum (gen-label))
- (L1 (gen-label)))
+ (done (gen-label))
+ (one-word-bignum (gen-label))
+ (L1 (gen-label)))
(inst test x #xe0000000)
(inst jmp :nz bignum)
;; Fixnum.
(emit-label done)
(assemble (*elsewhere*)
- (emit-label bignum)
- ;; Note: As on the mips port, space for a two word bignum is
- ;; always allocated and the header size is set to either one
- ;; or two words as appropriate.
- (inst jmp :ns one-word-bignum)
- ;; two word bignum
- (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
- n-widetag-bits)
- bignum-widetag))
- (inst jmp L1)
- (emit-label one-word-bignum)
- (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
- n-widetag-bits)
- bignum-widetag))
- (emit-label L1)
- (pseudo-atomic
- (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
- (storew y alloc)
- (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
- (storew x y bignum-digits-offset other-pointer-lowtag))
- (inst jmp done)))))
+ (emit-label bignum)
+ ;; Note: As on the mips port, space for a two word bignum is
+ ;; always allocated and the header size is set to either one
+ ;; or two words as appropriate.
+ (inst jmp :ns one-word-bignum)
+ ;; two word bignum
+ (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
+ n-widetag-bits)
+ bignum-widetag))
+ (inst jmp L1)
+ (emit-label one-word-bignum)
+ (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
+ n-widetag-bits)
+ bignum-widetag))
+ (emit-label L1)
+ (pseudo-atomic
+ (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
+ (storew y alloc)
+ (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
+ (storew x y bignum-digits-offset other-pointer-lowtag))
+ (inst jmp done)))))
(define-move-vop move-from-unsigned :move
(unsigned-reg) (descriptor-reg))
;;; Move untagged numbers.
(define-vop (word-move)
(:args (x :scs (signed-reg unsigned-reg) :target y
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:results (y :scs (signed-reg unsigned-reg)
- :load-if
- (not (or (location= x y)
- (and (sc-is x signed-reg unsigned-reg)
- (sc-is y signed-stack unsigned-stack))))))
+ :load-if
+ (not (or (location= x y)
+ (and (sc-is x signed-reg unsigned-reg)
+ (sc-is y signed-stack unsigned-stack))))))
(:effects)
(:affected)
(:note "word integer move")
;;; Move untagged number arguments/return-values.
(define-vop (move-word-arg)
(:args (x :scs (signed-reg unsigned-reg) :target y)
- (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
+ (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "word integer argument move")
(:generator 0
(move y x))
((signed-stack unsigned-stack)
(if (= (tn-offset fp) esp-offset)
- (storew x fp (tn-offset y)) ; c-call
- (storew x fp (- (1+ (tn-offset y)))))))))
+ (storew x fp (tn-offset y)) ; c-call
+ (storew x fp (- (1+ (tn-offset y)))))))))
(define-move-vop move-word-arg :move-arg
(descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
(defun catch-block-ea (tn)
(aver (sc-is tn catch-block))
(make-ea :dword :base ebp-tn
- :disp (- (* (+ (tn-offset tn) catch-block-size) n-word-bytes))))
+ :disp (- (* (+ (tn-offset tn) catch-block-size) n-word-bytes))))
\f
;;;; Save and restore dynamic environment.
(define-vop (save-dynamic-state)
(:results (catch :scs (descriptor-reg))
- (alien-stack :scs (descriptor-reg)))
+ (alien-stack :scs (descriptor-reg)))
(:generator 13
(load-tl-symbol-value catch *current-catch-block*)
(load-tl-symbol-value alien-stack *alien-stack*)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
- (alien-stack :scs (descriptor-reg)))
+ (alien-stack :scs (descriptor-reg)))
#!+sb-thread (:temporary (:sc unsigned-reg) temp)
(:generator 10
(store-tl-symbol-value catch *current-catch-block* temp)
(storew temp block unwind-block-current-uwp-slot)
(storew ebp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
- block catch-block-entry-pc-slot)))
+ block catch-block-entry-pc-slot)))
;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
;;; tag, and link the block into the CURRENT-CATCH list
(define-vop (make-catch-block)
(:args (tn)
- (tag :scs (any-reg descriptor-reg) :to (:result 1)))
+ (tag :scs (any-reg descriptor-reg) :to (:result 1)))
(:info entry-label)
(:results (block :scs (any-reg)))
(:temporary (:sc descriptor-reg) temp)
(storew temp block unwind-block-current-uwp-slot)
(storew ebp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
- block catch-block-entry-pc-slot)
+ block catch-block-entry-pc-slot)
(storew tag block catch-block-tag-slot)
(load-tl-symbol-value temp *current-catch-block*)
(storew temp block catch-block-previous-catch-slot)
;; Note: we can't list an sc-restriction, 'cause any load vops would
;; be inserted before the return-pc label.
(:args (sp)
- (start)
- (count))
+ (start)
+ (count))
(:results (values :more t))
(:temporary (:sc descriptor-reg) move-temp)
(:info label nvals)
(emit-label label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
- ((= nvals 1)
- (let ((no-values (gen-label)))
- (inst mov (tn-ref-tn values) nil-value)
- (inst jecxz no-values)
- (loadw (tn-ref-tn values) start -1)
- (emit-label no-values)))
- (t
- (collect ((defaults))
- (do ((i 0 (1+ i))
- (tn-ref values (tn-ref-across tn-ref)))
- ((null tn-ref))
- (let ((default-lab (gen-label))
- (tn (tn-ref-tn tn-ref)))
- (defaults (cons default-lab tn))
-
- (inst cmp count (fixnumize i))
- (inst jmp :le default-lab)
- (sc-case tn
- ((descriptor-reg any-reg)
- (loadw tn start (- (1+ i))))
- ((control-stack)
- (loadw move-temp start (- (1+ i)))
- (inst mov tn move-temp)))))
- (let ((defaulting-done (gen-label)))
- (emit-label defaulting-done)
- (assemble (*elsewhere*)
- (dolist (def (defaults))
- (emit-label (car def))
- (inst mov (cdr def) nil-value))
- (inst jmp defaulting-done))))))
+ ((= nvals 1)
+ (let ((no-values (gen-label)))
+ (inst mov (tn-ref-tn values) nil-value)
+ (inst jecxz no-values)
+ (loadw (tn-ref-tn values) start -1)
+ (emit-label no-values)))
+ (t
+ (collect ((defaults))
+ (do ((i 0 (1+ i))
+ (tn-ref values (tn-ref-across tn-ref)))
+ ((null tn-ref))
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn tn-ref)))
+ (defaults (cons default-lab tn))
+
+ (inst cmp count (fixnumize i))
+ (inst jmp :le default-lab)
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (loadw tn start (- (1+ i))))
+ ((control-stack)
+ (loadw move-temp start (- (1+ i)))
+ (inst mov tn move-temp)))))
+ (let ((defaulting-done (gen-label)))
+ (emit-label defaulting-done)
+ (assemble (*elsewhere*)
+ (dolist (def (defaults))
+ (emit-label (car def))
+ (inst mov (cdr def) nil-value))
+ (inst jmp defaulting-done))))))
(inst mov esp-tn sp)))
(define-vop (nlx-entry-multiple)
(:args (top)
- (source)
- (count :target ecx))
+ (source)
+ (count :target ecx))
;; Again, no SC restrictions for the args, 'cause the loading would
;; happen before the entry label.
(:info label)
(:temporary (:sc unsigned-reg :offset esi-offset) esi)
(:temporary (:sc unsigned-reg :offset edi-offset) edi)
(:results (result :scs (any-reg) :from (:argument 0))
- (num :scs (any-reg control-stack)))
+ (num :scs (any-reg control-stack)))
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(move result edi)
(inst sub edi n-word-bytes)
- (move ecx count) ; fixnum words == bytes
+ (move ecx count) ; fixnum words == bytes
(move num ecx)
- (inst shr ecx word-shift) ; word count for <rep movs>
+ (inst shr ecx word-shift) ; word count for <rep movs>
;; If we got zero, we be done.
(inst jecxz done)
;; Copy them down.
;;; These values were taken from the alpha code. The values for
;;; bias and exponent min/max are not the same as shown in the 486 book.
;;; They may be correct for how Python uses them.
-(def!constant single-float-bias 126) ; Intel says 127.
+(def!constant single-float-bias 126) ; Intel says 127.
(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp)
(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp)
;;; comment from CMU CL:
(defconstant-eqx long-float-significand-byte (byte 31 0) #'equalp)
(def!constant long-float-normal-exponent-min 1)
(def!constant long-float-normal-exponent-max #x7FFE)
-(def!constant long-float-hidden-bit (ash 1 31)) ; actually not hidden
+(def!constant long-float-hidden-bit (ash 1 31)) ; actually not hidden
(def!constant long-float-trapping-nan-bit (ash 1 30))
(def!constant single-float-digits
(+ (byte-size long-float-significand-byte) n-word-bits 1))
;;; pfw -- from i486 microprocessor programmer's reference manual
-(def!constant float-invalid-trap-bit (ash 1 0))
+(def!constant float-invalid-trap-bit (ash 1 0))
(def!constant float-denormal-trap-bit (ash 1 1))
(def!constant float-divide-by-zero-trap-bit (ash 1 2))
(def!constant float-overflow-trap-bit (ash 1 3))
(def!constant float-underflow-trap-bit (ash 1 4))
-(def!constant float-inexact-trap-bit (ash 1 5))
+(def!constant float-inexact-trap-bit (ash 1 5))
(def!constant float-round-to-nearest 0)
(def!constant float-round-to-negative 1)
fdefinition-object
;; free pointers
- ;;
+ ;;
;; Note that these are FIXNUM word counts, not (as one might
;; expect) byte counts or SAPs. The reason seems to be that by
- ;; representing them this way, we can avoid consing bignums.
+ ;; representing them this way, we can avoid consing bignums.
;; -- WHN 2000-10-02
*read-only-space-free-pointer*
*static-space-free-pointer*
*free-interrupt-context-index*
*free-tls-index*
-
+
*allocation-pointer*
*binding-stack-pointer*
*binding-stack-start*
;;; not immediate data.
(define-vop (if-eq)
(:args (x :scs (any-reg descriptor-reg control-stack constant)
- :load-if (not (and (sc-is x immediate)
- (sc-is y any-reg descriptor-reg
- control-stack constant))))
- (y :scs (any-reg descriptor-reg immediate)
- :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
- (sc-is y control-stack constant)))))
+ :load-if (not (and (sc-is x immediate)
+ (sc-is y any-reg descriptor-reg
+ control-stack constant))))
+ (y :scs (any-reg descriptor-reg immediate)
+ :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
+ (sc-is y control-stack constant)))))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(cond
((sc-is y immediate)
(let ((val (tn-value y)))
- (etypecase val
- (integer
- (if (and (zerop val) (sc-is x any-reg descriptor-reg))
- (inst test x x) ; smaller
- (inst cmp x (fixnumize val))))
- (symbol
- (inst cmp x (+ nil-value (static-symbol-offset val))))
- (character
- (inst cmp x (logior (ash (char-code val) n-widetag-bits)
- character-widetag))))))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is x any-reg descriptor-reg))
+ (inst test x x) ; smaller
+ (inst cmp x (fixnumize val))))
+ (symbol
+ (inst cmp x (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst cmp x (logior (ash (char-code val) n-widetag-bits)
+ character-widetag))))))
((sc-is x immediate) ; and y not immediate
;; Swap the order to fit the compare instruction.
(let ((val (tn-value x)))
- (etypecase val
- (integer
- (if (and (zerop val) (sc-is y any-reg descriptor-reg))
- (inst test y y) ; smaller
- (inst cmp y (fixnumize val))))
- (symbol
- (inst cmp y (+ nil-value (static-symbol-offset val))))
- (character
- (inst cmp y (logior (ash (char-code val) n-widetag-bits)
- character-widetag))))))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+ (inst test y y) ; smaller
+ (inst cmp y (fixnumize val))))
+ (symbol
+ (inst cmp y (+ nil-value (static-symbol-offset val))))
+ (character
+ (inst cmp y (logior (ash (char-code val) n-widetag-bits)
+ character-widetag))))))
(t
(inst cmp x y)))
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
-;;;;
+;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;;; Move untagged sap values.
(define-vop (sap-move)
(:args (x :target y
- :scs (sap-reg)
- :load-if (not (location= x y))))
+ :scs (sap-reg)
+ :load-if (not (location= x y))))
(:results (y :scs (sap-reg)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:note "SAP move")
(:effects)
(:affected)
;;; Move untagged sap arguments/return-values.
(define-vop (move-sap-arg)
(:args (x :target y
- :scs (sap-reg))
- (fp :scs (any-reg)
- :load-if (not (sc-is y sap-reg))))
+ :scs (sap-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "SAP argument move")
(:generator 0
(move y x))
(sap-stack
(if (= (tn-offset fp) esp-offset)
- (storew x fp (tn-offset y)) ; c-call
- (storew x fp (- (1+ (tn-offset y)))))))))
+ (storew x fp (tn-offset y)) ; c-call
+ (storew x fp (- (1+ (tn-offset y)))))))))
(define-move-vop move-sap-arg :move-arg
(descriptor-reg sap-reg) (sap-reg))
(define-vop (pointer+)
(:translate sap+)
(:args (ptr :scs (sap-reg) :target res
- :load-if (not (location= ptr res)))
- (offset :scs (signed-reg immediate)))
+ :load-if (not (location= ptr res)))
+ (offset :scs (signed-reg immediate)))
(:arg-types system-area-pointer signed-num)
(:results (res :scs (sap-reg) :from (:argument 0)
- :load-if (not (location= ptr res))))
+ :load-if (not (location= ptr res))))
(:result-types system-area-pointer)
(:policy :fast-safe)
(:generator 1
(cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg)
- (not (location= ptr res)))
- (sc-case offset
- (signed-reg
- (inst lea res (make-ea :dword :base ptr :index offset :scale 1)))
- (immediate
- (inst lea res (make-ea :dword :base ptr
- :disp (tn-value offset))))))
- (t
- (move res ptr)
- (sc-case offset
- (signed-reg
- (inst add res offset))
- (immediate
- (inst add res (tn-value offset))))))))
+ (not (location= ptr res)))
+ (sc-case offset
+ (signed-reg
+ (inst lea res (make-ea :dword :base ptr :index offset :scale 1)))
+ (immediate
+ (inst lea res (make-ea :dword :base ptr
+ :disp (tn-value offset))))))
+ (t
+ (move res ptr)
+ (sc-case offset
+ (signed-reg
+ (inst add res offset))
+ (immediate
+ (inst add res (tn-value offset))))))))
(define-vop (pointer-)
(:translate sap-)
(:args (ptr1 :scs (sap-reg) :target res)
- (ptr2 :scs (sap-reg)))
+ (ptr2 :scs (sap-reg)))
(:arg-types system-area-pointer system-area-pointer)
(:policy :fast-safe)
(:results (res :scs (signed-reg) :from (:argument 0)))
;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
(macrolet ((def-system-ref-and-set (ref-name
- set-name
- sc
- type
- size
- &optional signed)
- (let ((ref-name-c (symbolicate ref-name "-C"))
- (set-name-c (symbolicate set-name "-C"))
- (temp-sc (symbolicate size "-REG")))
- `(progn
- (define-vop (,ref-name)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg))
- (offset :scs (signed-reg)))
- (:arg-types system-area-pointer signed-num)
- ,@(unless (eq size :dword)
- `((:temporary (:sc ,temp-sc
- :from (:eval 0)
- :to (:eval 1))
- temp)))
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- (inst mov ,(if (eq size :dword) 'result 'temp)
- (make-ea ,size :base sap :index offset))
- ,@(unless (eq size :dword)
- `((inst ,(if signed 'movsx 'movzx)
- result temp)))))
- (define-vop (,ref-name-c)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg)))
- (:arg-types system-area-pointer
- (:constant (signed-byte 32)))
- (:info offset)
- ,@(unless (eq size :dword)
- `((:temporary (:sc ,temp-sc
- :from (:eval 0)
- :to (:eval 1))
- temp)))
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- (inst mov ,(if (eq size :dword) 'result 'temp)
- (make-ea ,size :base sap :disp offset))
- ,@(unless (eq size :dword)
- `((inst ,(if signed 'movsx 'movzx)
- result temp)))))
- (define-vop (,set-name)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg) :to (:eval 0))
- (offset :scs (signed-reg) :to (:eval 0))
- (value :scs (,sc)
- :target ,(if (eq size :dword)
- 'result
- 'temp)))
- (:arg-types system-area-pointer signed-num ,type)
- ,@(unless (eq size :dword)
- `((:temporary (:sc ,temp-sc :offset eax-offset
- :from (:argument 2) :to (:result 0)
- :target result)
- temp)))
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- ,@(unless (eq size :dword)
- `((move eax-tn value)))
- (inst mov (make-ea ,size
- :base sap
- :index offset)
- ,(if (eq size :dword) 'value 'temp))
- (move result
- ,(if (eq size :dword) 'value 'eax-tn))))
- (define-vop (,set-name-c)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg) :to (:eval 0))
- (value :scs (,sc)
- :target ,(if (eq size :dword)
- 'result
- 'temp)))
- (:arg-types system-area-pointer
- (:constant (signed-byte 32)) ,type)
- (:info offset)
- ,@(unless (eq size :dword)
- `((:temporary (:sc ,temp-sc :offset eax-offset
- :from (:argument 2) :to (:result 0)
- :target result)
- temp)))
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- ,@(unless (eq size :dword)
- `((move eax-tn value)))
- (inst mov
- (make-ea ,size :base sap :disp offset)
- ,(if (eq size :dword) 'value 'temp))
- (move result ,(if (eq size :dword)
- 'value
- 'eax-tn))))))))
+ set-name
+ sc
+ type
+ size
+ &optional signed)
+ (let ((ref-name-c (symbolicate ref-name "-C"))
+ (set-name-c (symbolicate set-name "-C"))
+ (temp-sc (symbolicate size "-REG")))
+ `(progn
+ (define-vop (,ref-name)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ ,@(unless (eq size :dword)
+ `((:temporary (:sc ,temp-sc
+ :from (:eval 0)
+ :to (:eval 1))
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ (inst mov ,(if (eq size :dword) 'result 'temp)
+ (make-ea ,size :base sap :index offset))
+ ,@(unless (eq size :dword)
+ `((inst ,(if signed 'movsx 'movzx)
+ result temp)))))
+ (define-vop (,ref-name-c)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg)))
+ (:arg-types system-area-pointer
+ (:constant (signed-byte 32)))
+ (:info offset)
+ ,@(unless (eq size :dword)
+ `((:temporary (:sc ,temp-sc
+ :from (:eval 0)
+ :to (:eval 1))
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ (inst mov ,(if (eq size :dword) 'result 'temp)
+ (make-ea ,size :base sap :disp offset))
+ ,@(unless (eq size :dword)
+ `((inst ,(if signed 'movsx 'movzx)
+ result temp)))))
+ (define-vop (,set-name)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (,sc)
+ :target ,(if (eq size :dword)
+ 'result
+ 'temp)))
+ (:arg-types system-area-pointer signed-num ,type)
+ ,@(unless (eq size :dword)
+ `((:temporary (:sc ,temp-sc :offset eax-offset
+ :from (:argument 2) :to (:result 0)
+ :target result)
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(unless (eq size :dword)
+ `((move eax-tn value)))
+ (inst mov (make-ea ,size
+ :base sap
+ :index offset)
+ ,(if (eq size :dword) 'value 'temp))
+ (move result
+ ,(if (eq size :dword) 'value 'eax-tn))))
+ (define-vop (,set-name-c)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (value :scs (,sc)
+ :target ,(if (eq size :dword)
+ 'result
+ 'temp)))
+ (:arg-types system-area-pointer
+ (:constant (signed-byte 32)) ,type)
+ (:info offset)
+ ,@(unless (eq size :dword)
+ `((:temporary (:sc ,temp-sc :offset eax-offset
+ :from (:argument 2) :to (:result 0)
+ :target result)
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ ,@(unless (eq size :dword)
+ `((move eax-tn value)))
+ (inst mov
+ (make-ea ,size :base sap :disp offset)
+ ,(if (eq size :dword) 'value 'temp))
+ (move result ,(if (eq size :dword)
+ 'value
+ 'eax-tn))))))))
(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
unsigned-reg positive-fixnum :byte nil)
(:translate sap-ref-double)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (offset :scs (signed-reg)))
+ (offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 5
(with-empty-tn@fp-top(result)
- (inst fldd (make-ea :dword :base sap :index offset)))))
+ (inst fldd (make-ea :dword :base sap :index offset)))))
(define-vop (sap-ref-double-c)
(:translate sap-ref-double)
(:result-types double-float)
(:generator 4
(with-empty-tn@fp-top(result)
- (inst fldd (make-ea :dword :base sap :disp offset)))))
+ (inst fldd (make-ea :dword :base sap :disp offset)))))
(define-vop (%set-sap-ref-double)
(:translate %set-sap-ref-double)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to (:eval 0))
- (offset :scs (signed-reg) :to (:eval 0))
- (value :scs (double-reg)))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (double-reg)))
(:arg-types system-area-pointer signed-num double-float)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 5
(cond ((zerop (tn-offset value))
- ;; Value is in ST0.
- (inst fstd (make-ea :dword :base sap :index offset))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fstd result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (inst fstd (make-ea :dword :base sap :index offset))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fstd value))
- (t
- ;; Neither value or result are in ST0.
- (unless (location= value result)
- (inst fstd result))
- (inst fxch value)))))))
+ ;; Value is in ST0.
+ (inst fstd (make-ea :dword :base sap :index offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fstd (make-ea :dword :base sap :index offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0.
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
(define-vop (%set-sap-ref-double-c)
(:translate %set-sap-ref-double)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to (:eval 0))
- (value :scs (double-reg)))
+ (value :scs (double-reg)))
(:arg-types system-area-pointer (:constant (signed-byte 32)) double-float)
(:info offset)
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 4
(cond ((zerop (tn-offset value))
- ;; Value is in ST0.
- (inst fstd (make-ea :dword :base sap :disp offset))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fstd result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (inst fstd (make-ea :dword :base sap :disp offset))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fstd value))
- (t
- ;; Neither value or result are in ST0.
- (unless (location= value result)
- (inst fstd result))
- (inst fxch value)))))))
+ ;; Value is in ST0.
+ (inst fstd (make-ea :dword :base sap :disp offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fstd (make-ea :dword :base sap :disp offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0.
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
\f
;;;; SAP-REF-SINGLE
(:translate sap-ref-single)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (offset :scs (signed-reg)))
+ (offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 5
(with-empty-tn@fp-top(result)
- (inst fld (make-ea :dword :base sap :index offset)))))
+ (inst fld (make-ea :dword :base sap :index offset)))))
(define-vop (sap-ref-single-c)
(:translate sap-ref-single)
(:result-types single-float)
(:generator 4
(with-empty-tn@fp-top(result)
- (inst fld (make-ea :dword :base sap :disp offset)))))
+ (inst fld (make-ea :dword :base sap :disp offset)))))
(define-vop (%set-sap-ref-single)
(:translate %set-sap-ref-single)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to (:eval 0))
- (offset :scs (signed-reg) :to (:eval 0))
- (value :scs (single-reg)))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (single-reg)))
(:arg-types system-area-pointer signed-num single-float)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 5
(cond ((zerop (tn-offset value))
- ;; Value is in ST0
- (inst fst (make-ea :dword :base sap :index offset))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fst result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (inst fst (make-ea :dword :base sap :index offset))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fst value))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value result)
- (inst fst result))
- (inst fxch value)))))))
+ ;; Value is in ST0
+ (inst fst (make-ea :dword :base sap :index offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fst result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fst (make-ea :dword :base sap :index offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fst value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fst result))
+ (inst fxch value)))))))
(define-vop (%set-sap-ref-single-c)
(:translate %set-sap-ref-single)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to (:eval 0))
- (value :scs (single-reg)))
+ (value :scs (single-reg)))
(:arg-types system-area-pointer (:constant (signed-byte 32)) single-float)
(:info offset)
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 4
(cond ((zerop (tn-offset value))
- ;; Value is in ST0
- (inst fst (make-ea :dword :base sap :disp offset))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fst result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (inst fst (make-ea :dword :base sap :disp offset))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fst value))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value result)
- (inst fst result))
- (inst fxch value)))))))
+ ;; Value is in ST0
+ (inst fst (make-ea :dword :base sap :disp offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fst result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fst (make-ea :dword :base sap :disp offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fst value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fst result))
+ (inst fxch value)))))))
\f
;;;; SAP-REF-LONG
(:translate sap-ref-long)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (offset :scs (signed-reg)))
+ (offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (result :scs (#!+long-float long-reg #!-long-float double-reg)))
(:result-types #!+long-float long-float #!-long-float double-float)
(:generator 5
(with-empty-tn@fp-top(result)
- (inst fldl (make-ea :dword :base sap :index offset)))))
+ (inst fldl (make-ea :dword :base sap :index offset)))))
(define-vop (sap-ref-long-c)
(:translate sap-ref-long)
(:result-types #!+long-float long-float #!-long-float double-float)
(:generator 4
(with-empty-tn@fp-top(result)
- (inst fldl (make-ea :dword :base sap :disp offset)))))
+ (inst fldl (make-ea :dword :base sap :disp offset)))))
#!+long-float
(define-vop (%set-sap-ref-long)
(:translate %set-sap-ref-long)
(:policy :fast-safe)
(:args (sap :scs (sap-reg) :to (:eval 0))
- (offset :scs (signed-reg) :to (:eval 0))
- (value :scs (long-reg)))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (long-reg)))
(:arg-types system-area-pointer signed-num long-float)
(:results (result :scs (long-reg)))
(:result-types long-float)
(:generator 5
(cond ((zerop (tn-offset value))
- ;; Value is in ST0
- (store-long-float (make-ea :dword :base sap :index offset))
- (unless (zerop (tn-offset result))
- ;; Value is in ST0 but not result.
- (inst fstd result)))
- (t
- ;; Value is not in ST0.
- (inst fxch value)
- (store-long-float (make-ea :dword :base sap :index offset))
- (cond ((zerop (tn-offset result))
- ;; The result is in ST0.
- (inst fstd value))
- (t
- ;; Neither value or result are in ST0
- (unless (location= value result)
- (inst fstd result))
- (inst fxch value)))))))
+ ;; Value is in ST0
+ (store-long-float (make-ea :dword :base sap :index offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (store-long-float (make-ea :dword :base sap :index offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
\f
;;; noise to convert normal lisp data objects into SAPs
(:generator 2
(move sap vector)
(inst add
- sap
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
+ sap
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
;;; Transforms for 64-bit SAP accessors.
(define-vop (print)
(:args (object :scs (descriptor-reg any-reg)))
(:temporary (:sc unsigned-reg
- :offset eax-offset
- :target result
- :from :eval
- :to (:result 0))
- eax)
+ :offset eax-offset
+ :target result
+ :from :eval
+ :to (:result 0))
+ eax)
(:results (result :scs (descriptor-reg)))
(:save-p t)
(:generator 100
(:vop-var vop)
(:node-var node)
(:temporary (:sc unsigned-reg :offset ebx-offset
- :from (:eval 0) :to (:eval 2)) ebx)
+ :from (:eval 0) :to (:eval 2)) ebx)
(:temporary (:sc unsigned-reg :offset ecx-offset
- :from (:eval 0) :to (:eval 2)) ecx))
+ :from (:eval 0) :to (:eval 2)) ecx))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun static-fun-template-name (num-args num-results)
(intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
- num-args num-results)))
+ num-args num-results)))
(defun moves (dst src)
(collect ((moves))
(do ((dst dst (cdr dst))
- (src src (cdr src)))
- ((or (null dst) (null src)))
+ (src src (cdr src)))
+ ((or (null dst) (null src)))
(moves `(move ,(car dst) ,(car src))))
(moves)))
(defun static-fun-template-vop (num-args num-results)
(unless (and (<= num-args register-arg-count)
- (<= num-results register-arg-count))
+ (<= num-results register-arg-count))
(error "either too many args (~W) or too many results (~W); max = ~W"
- num-args num-results register-arg-count))
+ num-args num-results register-arg-count))
(let ((num-temps (max num-args num-results)))
(collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
(dotimes (i num-results)
- (let ((result-name (intern (format nil "RESULT-~D" i))))
- (result-names result-name)
- (results `(,result-name :scs (any-reg descriptor-reg)))))
+ (let ((result-name (intern (format nil "RESULT-~D" i))))
+ (result-names result-name)
+ (results `(,result-name :scs (any-reg descriptor-reg)))))
(dotimes (i num-temps)
- (let ((temp-name (intern (format nil "TEMP-~D" i))))
- (temp-names temp-name)
- (temps `(:temporary (:sc descriptor-reg
- :offset ,(nth i *register-arg-offsets*)
- :from ,(if (< i num-args)
- `(:argument ,i)
- '(:eval 1))
- :to ,(if (< i num-results)
- `(:result ,i)
- '(:eval 1))
- ,@(when (< i num-results)
- `(:target ,(nth i (result-names)))))
- ,temp-name))))
+ (let ((temp-name (intern (format nil "TEMP-~D" i))))
+ (temp-names temp-name)
+ (temps `(:temporary (:sc descriptor-reg
+ :offset ,(nth i *register-arg-offsets*)
+ :from ,(if (< i num-args)
+ `(:argument ,i)
+ '(:eval 1))
+ :to ,(if (< i num-results)
+ `(:result ,i)
+ '(:eval 1))
+ ,@(when (< i num-results)
+ `(:target ,(nth i (result-names)))))
+ ,temp-name))))
(dotimes (i num-args)
- (let ((arg-name (intern (format nil "ARG-~D" i))))
- (arg-names arg-name)
- (args `(,arg-name
- :scs (any-reg descriptor-reg)
- :target ,(nth i (temp-names))))))
+ (let ((arg-name (intern (format nil "ARG-~D" i))))
+ (arg-names arg-name)
+ (args `(,arg-name
+ :scs (any-reg descriptor-reg)
+ :target ,(nth i (temp-names))))))
`(define-vop (,(static-fun-template-name num-args num-results)
- static-fun-template)
- (:args ,@(args))
- ,@(temps)
- (:results ,@(results))
- (:generator ,(+ 50 num-args num-results)
- ,@(moves (temp-names) (arg-names))
+ static-fun-template)
+ (:args ,@(args))
+ ,@(temps)
+ (:results ,@(results))
+ (:generator ,(+ 50 num-args num-results)
+ ,@(moves (temp-names) (arg-names))
- ;; If speed not more important than size, duplicate the
- ;; effect of the ENTER with discrete instructions. Takes
- ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes.
- (cond ((policy node (>= speed space))
- (inst mov ebx esp-tn)
- ;; Save the old-fp
- (inst push ebp-tn)
- ;; Ensure that at least three slots are available; one
- ;; above, two more needed.
- (inst sub esp-tn (fixnumize 2))
- (inst mov ebp-tn ebx))
- (t
- (inst enter (fixnumize 2))
- ;; The enter instruction pushes EBP and then copies
- ;; ESP into EBP. We want the new EBP to be the
- ;; original ESP, so we fix it up afterwards.
- (inst add ebp-tn (fixnumize 1))))
+ ;; If speed not more important than size, duplicate the
+ ;; effect of the ENTER with discrete instructions. Takes
+ ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes.
+ (cond ((policy node (>= speed space))
+ (inst mov ebx esp-tn)
+ ;; Save the old-fp
+ (inst push ebp-tn)
+ ;; Ensure that at least three slots are available; one
+ ;; above, two more needed.
+ (inst sub esp-tn (fixnumize 2))
+ (inst mov ebp-tn ebx))
+ (t
+ (inst enter (fixnumize 2))
+ ;; The enter instruction pushes EBP and then copies
+ ;; ESP into EBP. We want the new EBP to be the
+ ;; original ESP, so we fix it up afterwards.
+ (inst add ebp-tn (fixnumize 1))))
- ,(if (zerop num-args)
- '(inst xor ecx ecx)
- `(inst mov ecx (fixnumize ,num-args)))
+ ,(if (zerop num-args)
+ '(inst xor ecx ecx)
+ `(inst mov ecx (fixnumize ,num-args)))
- (note-this-location vop :call-site)
- ;; Old CMU CL comment:
- ;; STATIC-FUN-OFFSET gives the offset from the start of
- ;; the NIL object to the static function FDEFN and has the
- ;; low tag of 1 added. When the NIL symbol value with its
- ;; low tag of 3 is added the resulting value points to the
- ;; raw address slot of the fdefn (at +4).
- ;; FIXME: Since the fork from CMU CL, we've swapped
- ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the
- ;; text above is no longer right. Mysteriously, things still
- ;; work. It would be good to explain why. (Is this code no
- ;; longer executed? Does it not depend on the
- ;; 1+3=4=fdefn_raw_address_offset relationship above?
- ;; Is something else going on?)
- (inst call (make-ea :dword
- :disp (+ nil-value
- (static-fun-offset function))))
- ,(collect ((bindings) (links))
- (do ((temp (temp-names) (cdr temp))
- (name 'values (gensym))
- (prev nil name)
- (i 0 (1+ i)))
- ((= i num-results))
- (bindings `(,name
- (make-tn-ref ,(car temp) nil)))
- (when prev
- (links `(setf (tn-ref-across ,prev) ,name))))
- `(let ,(bindings)
- ,@(links)
- (default-unknown-values
- vop
- ,(if (zerop num-results) nil 'values)
- ,num-results)))
- ,@(moves (result-names) (temp-names)))))))
+ (note-this-location vop :call-site)
+ ;; Old CMU CL comment:
+ ;; STATIC-FUN-OFFSET gives the offset from the start of
+ ;; the NIL object to the static function FDEFN and has the
+ ;; low tag of 1 added. When the NIL symbol value with its
+ ;; low tag of 3 is added the resulting value points to the
+ ;; raw address slot of the fdefn (at +4).
+ ;; FIXME: Since the fork from CMU CL, we've swapped
+ ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the
+ ;; text above is no longer right. Mysteriously, things still
+ ;; work. It would be good to explain why. (Is this code no
+ ;; longer executed? Does it not depend on the
+ ;; 1+3=4=fdefn_raw_address_offset relationship above?
+ ;; Is something else going on?)
+ (inst call (make-ea :dword
+ :disp (+ nil-value
+ (static-fun-offset function))))
+ ,(collect ((bindings) (links))
+ (do ((temp (temp-names) (cdr temp))
+ (name 'values (gensym))
+ (prev nil name)
+ (i 0 (1+ i)))
+ ((= i num-results))
+ (bindings `(,name
+ (make-tn-ref ,(car temp) nil)))
+ (when prev
+ (links `(setf (tn-ref-across ,prev) ,name))))
+ `(let ,(bindings)
+ ,@(links)
+ (default-unknown-values
+ vop
+ ,(if (zerop num-results) nil 'values)
+ ,num-results)))
+ ,@(moves (result-names) (temp-names)))))))
) ; EVAL-WHEN
(macrolet ((frob (num-args num-res)
- (static-fun-template-vop (eval num-args) (eval num-res))))
+ (static-fun-template-vop (eval num-args) (eval num-res))))
(frob 0 1)
(frob 1 1)
(frob 2 1)
(frob 3 1))
(defmacro define-static-fun (name args &key (results '(x)) translate
- policy cost arg-types result-types)
+ policy cost arg-types result-types)
`(define-vop (,name
- ,(static-fun-template-name (length args)
- (length results)))
+ ,(static-fun-template-name (length args)
+ (length results)))
(:variant ',name)
(:note ,(format nil "static-fun ~@(~S~)" name))
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
,@(when policy
- `((:policy ,policy)))
+ `((:policy ,policy)))
,@(when cost
- `((:generator-cost ,cost)))
+ `((:generator-cost ,cost)))
,@(when arg-types
- `((:arg-types ,@arg-types)))
+ `((:arg-types ,@arg-types)))
,@(when result-types
- `((:result-types ,@result-types)))))
+ `((:result-types ,@result-types)))))
(:translate lowtag-of)
(:policy :fast-safe)
(:args (object :scs (any-reg descriptor-reg control-stack)
- :target result))
+ :target result))
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 1
(:translate (setf fun-subtype))
(:policy :fast-safe)
(:args (type :scs (unsigned-reg) :target eax)
- (function :scs (descriptor-reg)))
+ (function :scs (descriptor-reg)))
(:arg-types positive-fixnum *)
(:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
- :to (:result 0) :target result)
- eax)
+ :to (:result 0) :target result)
+ eax)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
(move eax type)
(inst mov
- (make-ea :byte :base function :disp (- fun-pointer-lowtag))
- al-tn)
+ (make-ea :byte :base function :disp (- fun-pointer-lowtag))
+ al-tn)
(move result eax)))
(define-vop (get-header-data)
(:translate set-header-data)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg) :target res :to (:result 0))
- (data :scs (any-reg) :target eax))
+ (data :scs (any-reg) :target eax))
(:arg-types * positive-fixnum)
(:results (res :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg :offset eax-offset
- :from (:argument 1) :to (:result 0)) eax)
+ :from (:argument 1) :to (:result 0)) eax)
(:generator 6
(move eax data)
(inst shl eax (- n-widetag-bits 2))
(define-vop (make-other-immediate-type)
(:args (val :scs (any-reg descriptor-reg) :target res)
- (type :scs (unsigned-reg immediate)))
+ (type :scs (unsigned-reg immediate)))
(:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
(:generator 2
(move res val)
(inst shl res (- n-widetag-bits 2))
(inst or res (sc-case type
- (unsigned-reg type)
- (immediate (tn-value type))))))
+ (unsigned-reg type)
+ (immediate (tn-value type))))))
\f
;;;; allocation
(loadw sap code 0 other-pointer-lowtag)
(inst shr sap n-widetag-bits)
(inst lea sap (make-ea :byte :base code :index sap :scale 4
- :disp (- other-pointer-lowtag)))))
+ :disp (- other-pointer-lowtag)))))
(define-vop (compute-fun)
(:args (code :scs (descriptor-reg) :to (:result 0))
- (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
+ (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
(:arg-types * positive-fixnum)
(:results (func :scs (descriptor-reg) :from (:argument 0)))
(:generator 10
(loadw func code 0 other-pointer-lowtag)
(inst shr func n-widetag-bits)
(inst lea func
- (make-ea :byte :base offset :index func :scale 4
- :disp (- fun-pointer-lowtag other-pointer-lowtag)))
+ (make-ea :byte :base offset :index func :scale 4
+ :disp (- fun-pointer-lowtag other-pointer-lowtag)))
(inst add func code)))
(define-vop (%simple-fun-self)
(:generator 3
(loadw result function simple-fun-self-slot fun-pointer-lowtag)
(inst lea result
- (make-ea :byte :base result
- :disp (- fun-pointer-lowtag
- (* simple-fun-code-offset n-word-bytes))))))
+ (make-ea :byte :base result
+ :disp (- fun-pointer-lowtag
+ (* simple-fun-code-offset n-word-bytes))))))
;;; The closure function slot is a pointer to raw code on X86 instead
;;; of a pointer to the code function object itself. This VOP is used
(:policy :fast-safe)
(:translate (setf %simple-fun-self))
(:args (new-self :scs (descriptor-reg) :target result :to :result)
- (function :scs (descriptor-reg) :to :result))
+ (function :scs (descriptor-reg) :to :result))
(:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
(:results (result :scs (descriptor-reg)))
(:generator 3
(inst lea temp
- (make-ea :byte :base new-self
- :disp (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag)))
+ (make-ea :byte :base new-self
+ :disp (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag)))
(storew temp function simple-fun-self-slot fun-pointer-lowtag)
(move result new-self)))
(inst break pending-interrupt-trap)))
#!+sb-thread
-(defknown current-thread-offset-sap ((unsigned-byte 32))
+(defknown current-thread-offset-sap ((unsigned-byte 32))
system-area-pointer (flushable))
#!+sb-thread
(:info index)
(:generator 0
(inst inc (make-ea :dword :base count-vector
- :disp (- (* (+ vector-data-offset index) n-word-bytes)
- other-pointer-lowtag)))))
+ :disp (- (* (+ vector-data-offset index) n-word-bytes)
+ other-pointer-lowtag)))))
(defun print-mem-access (value stream print-size-p dstate)
(declare (type list value)
- (type stream stream)
- (type (member t nil) print-size-p)
- (type sb!disassem:disassem-state dstate))
+ (type stream stream)
+ (type (member t nil) print-size-p)
+ (type sb!disassem:disassem-state dstate))
(when print-size-p
(princ (sb!disassem:dstate-get-prop dstate 'width) stream)
(princ '| PTR | stream))
(write-char #\[ stream)
(let ((firstp t))
(macrolet ((pel ((var val) &body body)
- ;; Print an element of the address, maybe with
- ;; a leading separator.
- `(let ((,var ,val))
- (when ,var
- (unless firstp
- (write-char #\+ stream))
- ,@body
- (setq firstp nil)))))
+ ;; Print an element of the address, maybe with
+ ;; a leading separator.
+ `(let ((,var ,val))
+ (when ,var
+ (unless firstp
+ (write-char #\+ stream))
+ ,@body
+ (setq firstp nil)))))
(pel (base-reg (first value))
- (print-addr-reg base-reg stream dstate))
+ (print-addr-reg base-reg stream dstate))
(pel (index-reg (third value))
- (print-addr-reg index-reg stream dstate)
- (let ((index-scale (fourth value)))
- (when (and index-scale (not (= index-scale 1)))
- (write-char #\* stream)
- (princ index-scale stream))))
+ (print-addr-reg index-reg stream dstate)
+ (let ((index-scale (fourth value)))
+ (when (and index-scale (not (= index-scale 1)))
+ (write-char #\* stream)
+ (princ index-scale stream))))
(let ((offset (second value)))
- (when (and offset (or firstp (not (zerop offset))))
- (unless (or firstp (minusp offset))
- (write-char #\+ stream))
- (if firstp
+ (when (and offset (or firstp (not (zerop offset))))
+ (unless (or firstp (minusp offset))
+ (write-char #\+ stream))
+ (if firstp
(progn
(sb!disassem:princ16 offset stream)
(or (minusp offset)
(defun generate-fixnum-test (value)
(let ((offset (tn-offset value)))
(cond ((and (sc-is value any-reg descriptor-reg)
- (or (= offset eax-offset) (= offset ebx-offset)
- (= offset ecx-offset) (= offset edx-offset)))
- (inst test (make-random-tn :kind :normal
- :sc (sc-or-lose 'byte-reg)
- :offset offset)
- 3))
- ((sc-is value control-stack)
- (inst test (make-ea :byte :base ebp-tn
- :disp (- (* (1+ offset) n-word-bytes)))
- 3))
- (t
- (inst test value 3)))))
+ (or (= offset eax-offset) (= offset ebx-offset)
+ (= offset ecx-offset) (= offset edx-offset)))
+ (inst test (make-random-tn :kind :normal
+ :sc (sc-or-lose 'byte-reg)
+ :offset offset)
+ 3))
+ ((sc-is value control-stack)
+ (inst test (make-ea :byte :base ebp-tn
+ :disp (- (* (1+ offset) n-word-bytes)))
+ 3))
+ (t
+ (inst test value 3)))))
(defun %test-fixnum (value target not-p)
(generate-fixnum-test value)
;; Code a single instruction byte test if possible.
(let ((offset (tn-offset value)))
(cond ((and (sc-is value any-reg descriptor-reg)
- (or (= offset eax-offset) (= offset ebx-offset)
- (= offset ecx-offset) (= offset edx-offset)))
- (inst cmp (make-random-tn :kind :normal
- :sc (sc-or-lose 'byte-reg)
- :offset offset)
- immediate))
- (t
- (move eax-tn value)
- (inst cmp al-tn immediate))))
+ (or (= offset eax-offset) (= offset ebx-offset)
+ (= offset ecx-offset) (= offset edx-offset)))
+ (inst cmp (make-random-tn :kind :normal
+ :sc (sc-or-lose 'byte-reg)
+ :offset offset)
+ immediate))
+ (t
+ (move eax-tn value)
+ (inst cmp al-tn immediate))))
(inst jmp (if not-p :ne :e) target))
(defun %test-lowtag (value target not-p lowtag &optional al-loaded)
(inst prefetchnta (make-ea :byte :base value :disp (- lowtag))))
(inst cmp al-tn lowtag)
(inst jmp (if not-p :ne :e) target))
-
+
(defun %test-headers (value target not-p function-p headers
- &optional (drop-through (gen-label)) al-loaded)
+ &optional (drop-through (gen-label)) al-loaded)
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind (equal less-or-equal greater-or-equal when-true when-false)
- ;; EQUAL, LESS-OR-EQUAL and GREATER-OR-EQUAL are the conditions for
- ;; branching to TARGET. WHEN-TRUE and WHEN-FALSE are the
- ;; labels to branch to when we know it's true and when we know
- ;; it's false respectively.
- (if not-p
- (values :ne :a :b drop-through target)
- (values :e :na :nb target drop-through))
+ ;; EQUAL, LESS-OR-EQUAL and GREATER-OR-EQUAL are the conditions for
+ ;; branching to TARGET. WHEN-TRUE and WHEN-FALSE are the
+ ;; labels to branch to when we know it's true and when we know
+ ;; it's false respectively.
+ (if not-p
+ (values :ne :a :b drop-through target)
+ (values :e :na :nb target drop-through))
(%test-lowtag value when-false t lowtag al-loaded)
(inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
(do ((remaining headers (cdr remaining)))
- ((null remaining))
- (let ((header (car remaining))
- (last (null (cdr remaining))))
- (cond
- ((atom header)
- (cond
- ((and (not last) (null (cddr remaining))
- (atom (cadr remaining))
- (= (logcount (logxor header (cadr remaining))) 1))
- ;; BASE-STRING, (VECTOR NIL), BIT-VECTOR, (VECTOR T)
- (inst and al-tn (ldb (byte 8 0) (logeqv header (cadr remaining))))
- (inst cmp al-tn (ldb (byte 8 0) (logand header (cadr remaining))))
- (inst jmp equal target)
- (return))
- (t
- (inst cmp al-tn header)
- (if last
- (inst jmp equal target)
- (inst jmp :e when-true)))))
- (t
- (let ((start (car header))
- (end (cdr header)))
- (cond
- ;; LAST = don't need al-tn later
- ((and last (not (= start bignum-widetag))
- (= (+ start 4) end) (= (logcount (logxor start end)) 1))
- ;; SIMPLE-STRING
- (inst and al-tn (ldb (byte 8 0) (logeqv start end)))
- (inst cmp al-tn (ldb (byte 8 0) (logand start end)))
- (inst jmp equal target))
- ((and (not last) (null (cddr remaining))
- (= (+ start 4) end) (= (logcount (logxor start end)) 1)
- (listp (cadr remaining))
- (= (+ (caadr remaining) 4) (cdadr remaining))
- (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
- (= (logcount (logxor (caadr remaining) start)) 1))
- ;; STRING
- (inst and al-tn (ldb (byte 8 0) (logeqv start (cdadr remaining))))
- (inst cmp al-tn (ldb (byte 8 0) (logand start (cdadr remaining))))
- (inst jmp equal target)
- ;; we've shortcircuited the DO, so we must return.
- ;; It's OK to do so, because (NULL (CDDR REMAINING))
- ;; was true.
- (return))
- (t
- (unless (= start bignum-widetag)
- (inst cmp al-tn start)
- (if (= end complex-array-widetag)
- (progn
- (aver last)
- (inst jmp greater-or-equal target))
- (inst jmp :b when-false))) ; was :l
- (unless (= end complex-array-widetag)
- (inst cmp al-tn end)
- (if last
- (inst jmp less-or-equal target)
- (inst jmp :be when-true)))))))))) ; was :le
+ ((null remaining))
+ (let ((header (car remaining))
+ (last (null (cdr remaining))))
+ (cond
+ ((atom header)
+ (cond
+ ((and (not last) (null (cddr remaining))
+ (atom (cadr remaining))
+ (= (logcount (logxor header (cadr remaining))) 1))
+ ;; BASE-STRING, (VECTOR NIL), BIT-VECTOR, (VECTOR T)
+ (inst and al-tn (ldb (byte 8 0) (logeqv header (cadr remaining))))
+ (inst cmp al-tn (ldb (byte 8 0) (logand header (cadr remaining))))
+ (inst jmp equal target)
+ (return))
+ (t
+ (inst cmp al-tn header)
+ (if last
+ (inst jmp equal target)
+ (inst jmp :e when-true)))))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ (cond
+ ;; LAST = don't need al-tn later
+ ((and last (not (= start bignum-widetag))
+ (= (+ start 4) end) (= (logcount (logxor start end)) 1))
+ ;; SIMPLE-STRING
+ (inst and al-tn (ldb (byte 8 0) (logeqv start end)))
+ (inst cmp al-tn (ldb (byte 8 0) (logand start end)))
+ (inst jmp equal target))
+ ((and (not last) (null (cddr remaining))
+ (= (+ start 4) end) (= (logcount (logxor start end)) 1)
+ (listp (cadr remaining))
+ (= (+ (caadr remaining) 4) (cdadr remaining))
+ (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
+ (= (logcount (logxor (caadr remaining) start)) 1))
+ ;; STRING
+ (inst and al-tn (ldb (byte 8 0) (logeqv start (cdadr remaining))))
+ (inst cmp al-tn (ldb (byte 8 0) (logand start (cdadr remaining))))
+ (inst jmp equal target)
+ ;; we've shortcircuited the DO, so we must return.
+ ;; It's OK to do so, because (NULL (CDDR REMAINING))
+ ;; was true.
+ (return))
+ (t
+ (unless (= start bignum-widetag)
+ (inst cmp al-tn start)
+ (if (= end complex-array-widetag)
+ (progn
+ (aver last)
+ (inst jmp greater-or-equal target))
+ (inst jmp :b when-false))) ; was :l
+ (unless (= end complex-array-widetag)
+ (inst cmp al-tn end)
+ (if last
+ (inst jmp less-or-equal target)
+ (inst jmp :be when-true)))))))))) ; was :le
(emit-label drop-through))))
\f
;;;; type checking and testing
(define-vop (simple-check-type)
(:args (value :target result :scs (any-reg descriptor-reg)))
(:results (result :scs (any-reg descriptor-reg)
- :load-if (not (and (sc-is value any-reg descriptor-reg)
- (sc-is result control-stack)))))
+ :load-if (not (and (sc-is value any-reg descriptor-reg)
+ (sc-is result control-stack)))))
(:vop-var vop)
(:save-p :compute-only))
(if (> (apply #'max type-codes) lowtag-limit) 7 2)))
(defmacro !define-type-vops (pred-name check-name ptype error-code
- (&rest type-codes)
- &key (variant nil variant-p) &allow-other-keys)
+ (&rest type-codes)
+ &key (variant nil variant-p) &allow-other-keys)
;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
;; expansion?
(let* ((cost (cost-to-test-types (mapcar #'eval type-codes)))
- (prefix (if variant-p
- (concatenate 'string (string variant) "-")
- "")))
+ (prefix (if variant-p
+ (concatenate 'string (string variant) "-")
+ "")))
`(progn
,@(when pred-name
- `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
- (:translate ,pred-name)
- (:generator ,cost
- (test-type value target not-p (,@type-codes))))))
+ `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value target not-p (,@type-codes))))))
,@(when check-name
- `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
- (:generator ,cost
- (let ((err-lab
- (generate-error-code vop ,error-code value)))
- (test-type value err-lab t (,@type-codes))
- (move result value))))))
+ `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
+ (:generator ,cost
+ (let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value err-lab t (,@type-codes))
+ (move result value))))))
,@(when ptype
- `((primitive-type-vop ,check-name (:check) ,ptype))))))
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
\f
;;;; other integer ranges
(:translate signed-byte-32-p)
(:generator 45
(multiple-value-bind (yep nope)
- (if not-p
- (values not-target target)
- (values target not-target))
+ (if not-p
+ (values not-target target)
+ (values target not-target))
(generate-fixnum-test value)
(inst jmp :e yep)
(move eax-tn value)
(define-vop (check-signed-byte-32 check-type)
(:generator 45
(let ((nope (generate-error-code vop
- object-not-signed-byte-32-error
- value)))
+ object-not-signed-byte-32-error
+ value)))
(generate-fixnum-test value)
(inst jmp :e yep)
(move eax-tn value)
(:translate unsigned-byte-32-p)
(:generator 45
(let ((not-target (gen-label))
- (single-word (gen-label))
- (fixnum (gen-label)))
+ (single-word (gen-label))
+ (fixnum (gen-label)))
(multiple-value-bind (yep nope)
- (if not-p
- (values not-target target)
- (values target not-target))
- ;; Is it a fixnum?
- (generate-fixnum-test value)
- (move eax-tn value)
- (inst jmp :e fixnum)
-
- ;; If not, is it an other pointer?
- (inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-lowtag)
- (inst jmp :ne nope)
- ;; Get the header.
- (loadw eax-tn value 0 other-pointer-lowtag)
- ;; Is it one?
- (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
- (inst jmp :e single-word)
- ;; If it's other than two, we can't be an (unsigned-byte 32)
- (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
- (inst jmp :ne nope)
- ;; Get the second digit.
- (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
- ;; All zeros, its an (unsigned-byte 32).
- (inst or eax-tn eax-tn)
- (inst jmp :z yep)
- (inst jmp nope)
-
- (emit-label single-word)
- ;; Get the single digit.
- (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
-
- ;; positive implies (unsigned-byte 32).
- (emit-label fixnum)
- (inst or eax-tn eax-tn)
- (inst jmp (if not-p :s :ns) target)
-
- (emit-label not-target)))))
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ ;; Is it a fixnum?
+ (generate-fixnum-test value)
+ (move eax-tn value)
+ (inst jmp :e fixnum)
+
+ ;; If not, is it an other pointer?
+ (inst and al-tn lowtag-mask)
+ (inst cmp al-tn other-pointer-lowtag)
+ (inst jmp :ne nope)
+ ;; Get the header.
+ (loadw eax-tn value 0 other-pointer-lowtag)
+ ;; Is it one?
+ (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (inst jmp :e single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 32)
+ (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
+ (inst jmp :ne nope)
+ ;; Get the second digit.
+ (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
+ ;; All zeros, its an (unsigned-byte 32).
+ (inst or eax-tn eax-tn)
+ (inst jmp :z yep)
+ (inst jmp nope)
+
+ (emit-label single-word)
+ ;; Get the single digit.
+ (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
+
+ ;; positive implies (unsigned-byte 32).
+ (emit-label fixnum)
+ (inst or eax-tn eax-tn)
+ (inst jmp (if not-p :s :ns) target)
+
+ (emit-label not-target)))))
(define-vop (check-unsigned-byte-32 check-type)
(:generator 45
(let ((nope
- (generate-error-code vop object-not-unsigned-byte-32-error value))
- (yep (gen-label))
- (fixnum (gen-label))
- (single-word (gen-label)))
+ (generate-error-code vop object-not-unsigned-byte-32-error value))
+ (yep (gen-label))
+ (fixnum (gen-label))
+ (single-word (gen-label)))
;; Is it a fixnum?
(generate-fixnum-test value)
(inst or eax-tn eax-tn)
(inst jmp :z yep)
(inst jmp nope)
-
+
(emit-label single-word)
;; Get the single digit.
(loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
(:results (start) (count))
(:info nvals)
(:generator 20
- (move temp esp-tn) ; WARN pointing 1 below
+ (move temp esp-tn) ; WARN pointing 1 below
(do ((val vals (tn-ref-across val)))
- ((null val))
+ ((null val))
(inst push (tn-ref-tn val)))
(move start temp)
(inst mov count (fixnumize nvals))))
(:arg-types list)
(:policy :fast-safe)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:temporary (:sc descriptor-reg :from (:argument 0) :to (:result 1)) list)
(:temporary (:sc descriptor-reg :to (:result 1)) nil-temp)
(:temporary (:sc unsigned-reg :offset eax-offset :to (:result 1)) eax)
(:save-p :compute-only)
(:generator 0
(move list arg)
- (move start esp-tn) ; WARN pointing 1 below
+ (move start esp-tn) ; WARN pointing 1 below
(inst mov nil-temp nil-value)
LOOP
(error-call vop bogus-arg-to-values-list-error list)
DONE
- (inst mov count start) ; start is high address
- (inst sub count esp-tn))) ; stackp is low address
+ (inst mov count start) ; start is high address
+ (inst sub count esp-tn))) ; stackp is low address
;;; Copy the more arg block to the top of the stack so we can use them
;;; as function arguments.
;;; defining a new stack frame.
(define-vop (%more-arg-values)
(:args (context :scs (descriptor-reg any-reg) :target src)
- (skip :scs (any-reg immediate))
- (num :scs (any-reg) :target count))
+ (skip :scs (any-reg immediate))
+ (num :scs (any-reg) :target count))
(:arg-types * positive-fixnum positive-fixnum)
(:temporary (:sc any-reg :offset esi-offset :from (:argument 0)) src)
(:temporary (:sc descriptor-reg :offset eax-offset) temp)
(:temporary (:sc unsigned-reg :offset ecx-offset) temp1)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:generator 20
(sc-case skip
(immediate
(cond ((zerop (tn-value skip))
- (move src context)
- (move count num))
- (t
- (inst lea src (make-ea :dword :base context
- :disp (- (* (tn-value skip)
- n-word-bytes))))
- (move count num)
- (inst sub count (* (tn-value skip) n-word-bytes)))))
+ (move src context)
+ (move count num))
+ (t
+ (inst lea src (make-ea :dword :base context
+ :disp (- (* (tn-value skip)
+ n-word-bytes))))
+ (move count num)
+ (inst sub count (* (tn-value skip) n-word-bytes)))))
(any-reg
(move src context)
(defvar *float-register-names* (make-array 8 :initial-element nil)))
(macrolet ((defreg (name offset size)
- (let ((offset-sym (symbolicate name "-OFFSET"))
- (names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((offset-sym (symbolicate name "-OFFSET"))
+ (names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET
;; (in the same file) depends on compile-time evaluation
;; of the DEFCONSTANT. -- AL 20010224
- (def!constant ,offset-sym ,offset))
- (setf (svref ,names-vector ,offset-sym)
- ,(symbol-name name)))))
- ;; FIXME: It looks to me as though DEFREGSET should also
- ;; define the related *FOO-REGISTER-NAMES* variable.
- (defregset (name &rest regs)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter ,name
- (list ,@(mapcar (lambda (name)
- (symbolicate name "-OFFSET"))
- regs))))))
+ (def!constant ,offset-sym ,offset))
+ (setf (svref ,names-vector ,offset-sym)
+ ,(symbol-name name)))))
+ ;; FIXME: It looks to me as though DEFREGSET should also
+ ;; define the related *FOO-REGISTER-NAMES* variable.
+ (defregset (name &rest regs)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter ,name
+ (list ,@(mapcar (lambda (name)
+ (symbolicate name "-OFFSET"))
+ regs))))))
;; byte registers
;;
(collect ((forms))
(let ((index 0))
(dolist (class classes)
- (let* ((sc-name (car class))
- (constant-name (symbolicate sc-name "-SC-NUMBER")))
- (forms `(define-storage-class ,sc-name ,index
- ,@(cdr class)))
- (forms `(def!constant ,constant-name ,index))
- (incf index))))
+ (let* ((sc-name (car class))
+ (constant-name (symbolicate sc-name "-SC-NUMBER")))
+ (forms `(define-storage-class ,sc-name ,index
+ ,@(cdr class)))
+ (forms `(def!constant ,constant-name ,index))
+ (incf index))))
`(progn
,@(forms))))
;;
;; the stacks
;;
-
+
;; the control stack
- (control-stack stack) ; may be pointers, scanned by GC
+ (control-stack stack) ; may be pointers, scanned by GC
;; the non-descriptor stacks
- (signed-stack stack) ; (signed-byte 32)
- (unsigned-stack stack) ; (unsigned-byte 32)
- (character-stack stack) ; non-descriptor characters.
- (sap-stack stack) ; System area pointers.
- (single-stack stack) ; single-floats
- (double-stack stack :element-size 2) ; double-floats.
+ (signed-stack stack) ; (signed-byte 32)
+ (unsigned-stack stack) ; (unsigned-byte 32)
+ (character-stack stack) ; non-descriptor characters.
+ (sap-stack stack) ; System area pointers.
+ (single-stack stack) ; single-floats
+ (double-stack stack :element-size 2) ; double-floats.
#!+long-float
- (long-stack stack :element-size 3) ; long-floats.
- (complex-single-stack stack :element-size 2) ; complex-single-floats
- (complex-double-stack stack :element-size 4) ; complex-double-floats
+ (long-stack stack :element-size 3) ; long-floats.
+ (complex-single-stack stack :element-size 2) ; complex-single-floats
+ (complex-double-stack stack :element-size 4) ; complex-double-floats
#!+long-float
- (complex-long-stack stack :element-size 6) ; complex-long-floats
+ (complex-long-stack stack :element-size 6) ; complex-long-floats
;;
;; magic SCs
;; immediate descriptor objects. Don't have to be seen by GC, but nothing
;; bad will happen if they are. (fixnums, characters, header values, etc).
(any-reg registers
- :locations #.*dword-regs*
- :element-size 2
-; :reserve-locations (#.eax-offset)
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (control-stack))
+ :locations #.*dword-regs*
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (control-stack))
;; pointer descriptor objects -- must be seen by GC
(descriptor-reg registers
- :locations #.*dword-regs*
- :element-size 2
-; :reserve-locations (#.eax-offset)
- :constant-scs (constant immediate)
- :save-p t
- :alternate-scs (control-stack))
+ :locations #.*dword-regs*
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (constant immediate)
+ :save-p t
+ :alternate-scs (control-stack))
;; non-descriptor characters
(character-reg registers
- :locations #!-sb-unicode #.*byte-regs*
+ :locations #!-sb-unicode #.*byte-regs*
#!+sb-unicode #.*dword-regs*
#!-sb-unicode #!-sb-unicode
- :reserve-locations (#.ah-offset #.al-offset)
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (character-stack))
+ :reserve-locations (#.ah-offset #.al-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (character-stack))
;; non-descriptor SAPs (arbitrary pointers into address space)
(sap-reg registers
- :locations #.*dword-regs*
- :element-size 2
-; :reserve-locations (#.eax-offset)
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (sap-stack))
+ :locations #.*dword-regs*
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (sap-stack))
;; non-descriptor (signed or unsigned) numbers
(signed-reg registers
- :locations #.*dword-regs*
- :element-size 2
-; :reserve-locations (#.eax-offset)
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (signed-stack))
+ :locations #.*dword-regs*
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (signed-stack))
(unsigned-reg registers
- :locations #.*dword-regs*
- :element-size 2
-; :reserve-locations (#.eax-offset)
- :constant-scs (immediate)
- :save-p t
- :alternate-scs (unsigned-stack))
+ :locations #.*dword-regs*
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (unsigned-stack))
;; miscellaneous objects that must not be seen by GC. Used only as
;; temporaries.
(word-reg registers
- :locations #.*word-regs*
- :element-size 2
-; :reserve-locations (#.ax-offset)
- )
+ :locations #.*word-regs*
+ :element-size 2
+; :reserve-locations (#.ax-offset)
+ )
(byte-reg registers
- :locations #.*byte-regs*
-; :reserve-locations (#.al-offset #.ah-offset)
- )
+ :locations #.*byte-regs*
+; :reserve-locations (#.al-offset #.ah-offset)
+ )
;; that can go in the floating point registers
;; non-descriptor SINGLE-FLOATs
(single-reg float-registers
- :locations (0 1 2 3 4 5 6 7)
- :constant-scs (fp-constant)
- :save-p t
- :alternate-scs (single-stack))
+ :locations (0 1 2 3 4 5 6 7)
+ :constant-scs (fp-constant)
+ :save-p t
+ :alternate-scs (single-stack))
;; non-descriptor DOUBLE-FLOATs
(double-reg float-registers
- :locations (0 1 2 3 4 5 6 7)
- :constant-scs (fp-constant)
- :save-p t
- :alternate-scs (double-stack))
+ :locations (0 1 2 3 4 5 6 7)
+ :constant-scs (fp-constant)
+ :save-p t
+ :alternate-scs (double-stack))
;; non-descriptor LONG-FLOATs
#!+long-float
(long-reg float-registers
- :locations (0 1 2 3 4 5 6 7)
- :constant-scs (fp-constant)
- :save-p t
- :alternate-scs (long-stack))
+ :locations (0 1 2 3 4 5 6 7)
+ :constant-scs (fp-constant)
+ :save-p t
+ :alternate-scs (long-stack))
(complex-single-reg float-registers
- :locations (0 2 4 6)
- :element-size 2
- :constant-scs ()
- :save-p t
- :alternate-scs (complex-single-stack))
+ :locations (0 2 4 6)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-single-stack))
(complex-double-reg float-registers
- :locations (0 2 4 6)
- :element-size 2
- :constant-scs ()
- :save-p t
- :alternate-scs (complex-double-stack))
+ :locations (0 2 4 6)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-double-stack))
#!+long-float
(complex-long-reg float-registers
- :locations (0 2 4 6)
- :element-size 2
- :constant-scs ()
- :save-p t
- :alternate-scs (complex-long-stack))
+ :locations (0 2 4 6)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-long-stack))
;; a catch or unwind block
(catch-block stack :element-size kludge-nondeterministic-catch-block-size))
;;;; miscellaneous TNs for the various registers
(macrolet ((def-misc-reg-tns (sc-name &rest reg-names)
- (collect ((forms))
- (dolist (reg-name reg-names)
- (let ((tn-name (symbolicate reg-name "-TN"))
- (offset-name (symbolicate reg-name "-OFFSET")))
- ;; FIXME: It'd be good to have the special
- ;; variables here be named with the *FOO*
- ;; convention.
- (forms `(defparameter ,tn-name
- (make-random-tn :kind :normal
- :sc (sc-or-lose ',sc-name)
- :offset
- ,offset-name)))))
- `(progn ,@(forms)))))
+ (collect ((forms))
+ (dolist (reg-name reg-names)
+ (let ((tn-name (symbolicate reg-name "-TN"))
+ (offset-name (symbolicate reg-name "-OFFSET")))
+ ;; FIXME: It'd be good to have the special
+ ;; variables here be named with the *FOO*
+ ;; convention.
+ (forms `(defparameter ,tn-name
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose ',sc-name)
+ :offset
+ ,offset-name)))))
+ `(progn ,@(forms)))))
(def-misc-reg-tns unsigned-reg eax ebx ecx edx ebp esp edi esi)
(def-misc-reg-tns word-reg ax bx cx dx bp sp di si)
;;; TNs for registers used to pass arguments
(defparameter *register-arg-tns*
(mapcar (lambda (register-arg-name)
- (symbol-value (symbolicate register-arg-name "-TN")))
- *register-arg-names*))
+ (symbol-value (symbolicate register-arg-name "-TN")))
+ *register-arg-names*))
;;; FIXME: doesn't seem to be used in SBCL
#|
;;; added by pw
(defparameter fp-constant-tn
(make-random-tn :kind :normal
- :sc (sc-or-lose 'fp-constant)
- :offset 31)) ; Offset doesn't get used.
+ :sc (sc-or-lose 'fp-constant)
+ :offset 31)) ; Offset doesn't get used.
|#
\f
;;; If value can be represented as an immediate constant, then return
(!def-vm-support-routine immediate-constant-sc (value)
(typecase value
((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
- #-sb-xc-host system-area-pointer character)
+ #-sb-xc-host system-area-pointer character)
(sc-number-or-lose 'immediate))
(symbol
(when (static-symbol-p value)
#!+long-float
(long-float
(when (or (eql value 0l0) (eql value 1l0)
- (eql value pi)
- (eql value (log 10l0 2l0))
- (eql value (log 2.718281828459045235360287471352662L0 2l0))
- (eql value (log 2l0 10l0))
- (eql value (log 2l0 2.718281828459045235360287471352662L0)))
+ (eql value pi)
+ (eql value (log 10l0 2l0))
+ (eql value (log 2.718281828459045235360287471352662L0 2l0))
+ (eql value (log 2l0 10l0))
+ (eql value (log 2l0 2.718281828459045235360287471352662L0)))
(sc-number-or-lose 'fp-constant)))))
\f
;;;; miscellaneous function call parameters
;;; names of these things seem to have changed. these aliases by jrd
(def!constant lra-save-offset return-pc-save-offset)
-(def!constant cfp-offset ebp-offset) ; pfw - needed by stuff in /code
- ; related to signal context stuff
+(def!constant cfp-offset ebp-offset) ; pfw - needed by stuff in /code
+ ; related to signal context stuff
;;; This is used by the debugger.
(def!constant single-value-return-byte-offset 2)
(!def-vm-support-routine location-print-name (tn)
(declare (type tn tn))
(let* ((sc (tn-sc tn))
- (sb (sb-name (sc-sb sc)))
- (offset (tn-offset tn)))
+ (sb (sb-name (sc-sb sc)))
+ (offset (tn-offset tn)))
(ecase sb
(registers
(let* ((sc-name (sc-name sc))
- (name-vec (cond ((member sc-name *byte-sc-names*)
- *byte-register-names*)
- ((member sc-name *word-sc-names*)
- *word-register-names*)
- ((member sc-name *dword-sc-names*)
- *dword-register-names*))))
- (or (and name-vec
- (< -1 offset (length name-vec))
- (svref name-vec offset))
- ;; FIXME: Shouldn't this be an ERROR?
- (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
+ (name-vec (cond ((member sc-name *byte-sc-names*)
+ *byte-register-names*)
+ ((member sc-name *word-sc-names*)
+ *word-register-names*)
+ ((member sc-name *dword-sc-names*)
+ *dword-register-names*))))
+ (or (and name-vec
+ (< -1 offset (length name-vec))
+ (svref name-vec offset))
+ ;; FIXME: Shouldn't this be an ERROR?
+ (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
(float-registers (format nil "FR~D" offset))
(stack (format nil "S~D" offset))
(constant (format nil "Const~D" offset))
;;; 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.47"
+"0.9.2.48"
projects / sbcl.git / commitdiff