(:temporary (:scs (descriptor-reg) :type list) ptr)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
- res)
+ res)
(:info num)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(move (tn-ref-tn things) result))
(t
(macrolet
- ((maybe-load (tn)
- (once-only ((tn tn))
- `(sc-case ,tn
- ((any-reg descriptor-reg zero null)
- ,tn)
- (control-stack
- (load-stack-tn temp ,tn)
- temp)))))
- (let* ((cons-cells (if star (1- num) num))
- (alloc (* (pad-data-block cons-size) cons-cells)))
- (pseudo-atomic (:extra alloc)
- (move alloc-tn res)
- (inst dep list-pointer-lowtag 31 3 res)
- (move res ptr)
- (dotimes (i (1- cons-cells))
- (storew (maybe-load (tn-ref-tn things)) ptr
- cons-car-slot list-pointer-lowtag)
- (setf things (tn-ref-across things))
- (inst addi (pad-data-block cons-size) ptr ptr)
- (storew ptr ptr
- (- cons-cdr-slot cons-size)
- list-pointer-lowtag))
- (storew (maybe-load (tn-ref-tn things)) ptr
- cons-car-slot list-pointer-lowtag)
- (storew (if star
- (maybe-load (tn-ref-tn (tn-ref-across things)))
- null-tn)
- ptr cons-cdr-slot list-pointer-lowtag))
- (move res result)))))))
+ ((maybe-load (tn)
+ (once-only ((tn tn))
+ `(sc-case ,tn
+ ((any-reg descriptor-reg zero null)
+ ,tn)
+ (control-stack
+ (load-stack-tn temp ,tn)
+ temp)))))
+ (let* ((cons-cells (if star (1- num) num))
+ (alloc (* (pad-data-block cons-size) cons-cells)))
+ (pseudo-atomic (:extra alloc)
+ (move alloc-tn res)
+ (inst dep list-pointer-lowtag 31 3 res)
+ (move res ptr)
+ (dotimes (i (1- cons-cells))
+ (storew (maybe-load (tn-ref-tn things)) ptr
+ cons-car-slot list-pointer-lowtag)
+ (setf things (tn-ref-across things))
+ (inst addi (pad-data-block cons-size) ptr ptr)
+ (storew ptr ptr
+ (- cons-cdr-slot cons-size)
+ list-pointer-lowtag))
+ (storew (maybe-load (tn-ref-tn things)) ptr
+ cons-car-slot list-pointer-lowtag)
+ (storew (if star
+ (maybe-load (tn-ref-tn (tn-ref-across things)))
+ null-tn)
+ ptr cons-cdr-slot list-pointer-lowtag))
+ (move res result)))))))
(define-vop (list list-or-list*)
(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg))
- (unboxed-arg :scs (any-reg)))
+ (unboxed-arg :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed)
(:generator 10
(let ((size (+ length closure-info-offset)))
(pseudo-atomic (:extra (pad-data-block size))
- (inst move alloc-tn result)
- (inst dep fun-pointer-lowtag 31 3 result)
- (inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp)
- (storew temp result 0 fun-pointer-lowtag)))
+ (inst move alloc-tn result)
+ (inst dep fun-pointer-lowtag 31 3 result)
+ (inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp)
+ (storew temp result 0 fun-pointer-lowtag)))
(storew function result closure-fun-slot fun-pointer-lowtag)))
;;; The compiler likes to be able to directly make value cells.
-;;;
+;;;
(define-vop (make-value-cell)
(:args (value :to :save :scs (descriptor-reg any-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (result :scs (descriptor-reg)))
(:generator 10
(with-fixed-allocation
- (result temp value-cell-header-widetag value-cell-size))
+ (result temp value-cell-header-widetag value-cell-size))
(storew value result value-cell-value-slot other-pointer-lowtag)))
(inst move alloc-tn result)
(inst dep lowtag 31 3 result)
(when type
- (inst li (logior (ash (1- words) n-widetag-bits) type) temp)
- (storew temp result 0 lowtag)))))
+ (inst li (logior (ash (1- words) n-widetag-bits) type) temp)
+ (storew temp result 0 lowtag)))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
(define-vop (fast-lognot/fixnum fixnum-unop)
(:temporary (:scs (any-reg) :type fixnum :to (:result 0))
- temp)
+ temp)
(:translate lognot)
(:generator 2
(inst li (fixnumize -1) temp)
(define-vop (fast-fixnum-binop)
(:args (x :target r :scs (any-reg))
- (y :target r :scs (any-reg)))
+ (y :target r :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(define-vop (fast-unsigned-binop)
(:args (x :target r :scs (unsigned-reg))
- (y :target r :scs (unsigned-reg)))
+ (y :target r :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(define-vop (fast-signed-binop)
(:args (x :target r :scs (signed-reg))
- (y :target r :scs (signed-reg)))
+ (y :target r :scs (signed-reg)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(defmacro define-binop (translate cost untagged-cost op &optional arg-swap)
`(progn
(define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
- fast-fixnum-binop)
+ fast-fixnum-binop)
(:args (x :target r :scs (any-reg))
- (y :target r :scs (any-reg)))
+ (y :target r :scs (any-reg)))
(:translate ,translate)
(:generator ,cost
- ,(if arg-swap
- `(inst ,op y x r)
- `(inst ,op x y r))))
+ ,(if arg-swap
+ `(inst ,op y x r)
+ `(inst ,op x y r))))
(define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
- fast-signed-binop)
+ fast-signed-binop)
(:args (x :target r :scs (signed-reg))
- (y :target r :scs (signed-reg)))
+ (y :target r :scs (signed-reg)))
(:translate ,translate)
(:generator ,untagged-cost
- ,(if arg-swap
- `(inst ,op y x r)
- `(inst ,op x y r))))
+ ,(if arg-swap
+ `(inst ,op y x r)
+ `(inst ,op x y r))))
(define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
- fast-unsigned-binop)
+ fast-unsigned-binop)
(:args (x :target r :scs (unsigned-reg))
- (y :target r :scs (unsigned-reg)))
+ (y :target r :scs (unsigned-reg)))
(:translate ,translate)
(:generator ,untagged-cost
- ,(if arg-swap
- `(inst ,op y x r)
- `(inst ,op x y r))))))
+ ,(if arg-swap
+ `(inst ,op y x r)
+ `(inst ,op x y r))))))
(define-binop + 2 6 add)
(define-binop - 2 6 sub)
(:arg-types tagged-num (:constant integer)))
(defmacro define-c-binop (translate cost untagged-cost tagged-type
- untagged-type inst)
+ untagged-type inst)
`(progn
(define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
- fast-fixnum-c-binop)
+ fast-fixnum-c-binop)
(:arg-types tagged-num (:constant ,tagged-type))
(:translate ,translate)
(:generator ,cost
- (let ((y (fixnumize y)))
- ,inst)))
+ (let ((y (fixnumize y)))
+ ,inst)))
(define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
- fast-signed-c-binop)
+ fast-signed-c-binop)
(:arg-types signed-num (:constant ,untagged-type))
(:translate ,translate)
(:generator ,untagged-cost
- ,inst))
+ ,inst))
(define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
- fast-unsigned-c-binop)
+ fast-unsigned-c-binop)
(:arg-types unsigned-num (:constant ,untagged-type))
(:translate ,translate)
(:generator ,untagged-cost
- ,inst))))
+ ,inst))))
(define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
(inst addi y x r))
(:translate ash)
(:note "inline word ASH")
(:args (number :scs (unsigned-reg))
- (count :scs (signed-reg)))
+ (count :scs (signed-reg)))
(:arg-types unsigned-num tagged-num)
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:results (result :scs (unsigned-reg)))
(:translate ash)
(:note "inline word ASH")
(:args (number :scs (signed-reg))
- (count :scs (signed-reg)))
+ (count :scs (signed-reg)))
(:arg-types signed-num tagged-num)
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:results (result :scs (signed-reg)))
(:result-types unsigned-num)
(:generator 1
(cond ((< count 0)
- ;; It is a right shift.
- (inst srl number (min (- count) 31) result))
- ((> count 0)
- ;; It is a left shift.
- (inst sll number (min count 31) result))
- (t
- ;; Count=0? Shouldn't happen, but it's easy:
- (move number result)))))
+ ;; It is a right shift.
+ (inst srl number (min (- count) 31) result))
+ ((> count 0)
+ ;; It is a left shift.
+ (inst sll number (min count 31) result))
+ (t
+ ;; Count=0? Shouldn't happen, but it's easy:
+ (move number result)))))
(define-vop (fast-ash-c/signed=>signed)
(:policy :fast-safe)
(:result-types signed-num)
(:generator 1
(cond ((< count 0)
- ;; It is a right shift.
- (inst sra number (min (- count) 31) result))
- ((> count 0)
- ;; It is a left shift.
- (inst sll number (min count 31) result))
- (t
- ;; Count=0? Shouldn't happen, but it's easy:
- (move number result)))))
+ ;; It is a right shift.
+ (inst sra number (min (- count) 31) result))
+ ((> count 0)
+ ;; It is a left shift.
+ (inst sll number (min count 31) result))
+ (t
+ ;; Count=0? Shouldn't happen, but it's easy:
+ (move number result)))))
;;; FIXME: implement FAST-ASH-LEFT/UNSIGNED=>UNSIGNED and friends, for
;;; use in modular ASH (and because they're useful anyway). -- CSR,
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
- :target res) num)
+ :target res) num)
(:temporary (:scs (non-descriptor-reg)) mask temp)
(:generator 30
(inst li #x55555555 mask)
(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
(:args (x :scs (any-reg) :target x-pass)
- (y :scs (any-reg) :target y-pass))
+ (y :scs (any-reg) :target y-pass))
(:temporary (:sc signed-reg :offset nl0-offset
- :from (:argument 0) :to (:result 0)) x-pass)
+ :from (:argument 0) :to (:result 0)) x-pass)
(:temporary (:sc signed-reg :offset nl1-offset
- :from (:argument 1) :to (:result 0)) y-pass)
+ :from (:argument 1) :to (:result 0)) y-pass)
(:temporary (:sc signed-reg :offset nl2-offset :target r
- :from (:argument 1) :to (:result 0)) res-pass)
+ :from (:argument 1) :to (:result 0)) res-pass)
(:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
(:temporary (:sc signed-reg :offset nl4-offset
- :from (:argument 1) :to (:result 0)) sign)
+ :from (:argument 1) :to (:result 0)) sign)
(:temporary (:sc interior-reg :offset lip-offset) lip)
(:ignore lip sign)
(:translate *)
(inst ldil fixup tmp)
(inst ble fixup lisp-heap-space tmp))
(if (location= y y-pass)
- (inst sra x 2 x-pass)
- (inst move y y-pass))
+ (inst sra x 2 x-pass)
+ (inst move y y-pass))
(move res-pass r)))
(define-vop (fast-*/signed=>signed fast-signed-binop)
(:translate *)
(:args (x :scs (signed-reg) :target x-pass)
- (y :scs (signed-reg) :target y-pass))
+ (y :scs (signed-reg) :target y-pass))
(:temporary (:sc signed-reg :offset nl0-offset
- :from (:argument 0) :to (:result 0)) x-pass)
+ :from (:argument 0) :to (:result 0)) x-pass)
(:temporary (:sc signed-reg :offset nl1-offset
- :from (:argument 1) :to (:result 0)) y-pass)
+ :from (:argument 1) :to (:result 0)) y-pass)
(:temporary (:sc signed-reg :offset nl2-offset :target r
- :from (:argument 1) :to (:result 0)) res-pass)
+ :from (:argument 1) :to (:result 0)) res-pass)
(:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
(:temporary (:sc signed-reg :offset nl4-offset
- :from (:argument 1) :to (:result 0)) sign)
+ :from (:argument 1) :to (:result 0)) sign)
(:temporary (:sc interior-reg :offset lip-offset) lip)
(:ignore lip sign)
(:translate *)
(define-vop (fast-truncate/fixnum fast-fixnum-binop)
(:translate truncate)
(:args (x :scs (any-reg) :target x-pass)
- (y :scs (any-reg) :target y-pass))
+ (y :scs (any-reg) :target y-pass))
(:temporary (:sc signed-reg :offset nl0-offset
- :from (:argument 0) :to (:result 0)) x-pass)
+ :from (:argument 0) :to (:result 0)) x-pass)
(:temporary (:sc signed-reg :offset nl1-offset
- :from (:argument 1) :to (:result 0)) y-pass)
+ :from (:argument 1) :to (:result 0)) y-pass)
(:temporary (:sc signed-reg :offset nl2-offset :target q
- :from (:argument 1) :to (:result 0)) q-pass)
+ :from (:argument 1) :to (:result 0)) q-pass)
(:temporary (:sc signed-reg :offset nl3-offset :target r
- :from (:argument 1) :to (:result 1)) r-pass)
+ :from (:argument 1) :to (:result 1)) r-pass)
(:results (q :scs (signed-reg))
- (r :scs (any-reg)))
+ (r :scs (any-reg)))
(:result-types tagged-num tagged-num)
(:vop-var vop)
(:save-p :compute-only)
(define-vop (fast-truncate/signed fast-signed-binop)
(:translate truncate)
(:args (x :scs (signed-reg) :target x-pass)
- (y :scs (signed-reg) :target y-pass))
+ (y :scs (signed-reg) :target y-pass))
(:temporary (:sc signed-reg :offset nl0-offset
- :from (:argument 0) :to (:result 0)) x-pass)
+ :from (:argument 0) :to (:result 0)) x-pass)
(:temporary (:sc signed-reg :offset nl1-offset
- :from (:argument 1) :to (:result 0)) y-pass)
+ :from (:argument 1) :to (:result 0)) y-pass)
(:temporary (:sc signed-reg :offset nl2-offset :target q
- :from (:argument 1) :to (:result 0)) q-pass)
+ :from (:argument 1) :to (:result 0)) q-pass)
(:temporary (:sc signed-reg :offset nl3-offset :target r
- :from (:argument 1) :to (:result 1)) r-pass)
+ :from (:argument 1) :to (:result 1)) r-pass)
(:results (q :scs (signed-reg))
- (r :scs (signed-reg)))
+ (r :scs (signed-reg)))
(:result-types signed-num signed-num)
(:vop-var vop)
(:save-p :compute-only)
(define-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg))
- (y :scs (any-reg)))
+ (y :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison"))
(define-vop (fast-conditional/signed fast-conditional)
(:args (x :scs (signed-reg))
- (y :scs (signed-reg)))
+ (y :scs (signed-reg)))
(:arg-types signed-num signed-num)
(:note "inline (signed-byte 32) comparison"))
(define-vop (fast-conditional/unsigned fast-conditional)
(:args (x :scs (unsigned-reg))
- (y :scs (unsigned-reg)))
+ (y :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 32) comparison"))
(defmacro define-conditional-vop (translate signed-cond unsigned-cond)
`(progn
,@(mapcar #'(lambda (suffix cost signed imm)
- (unless (and (member suffix '(/fixnum -c/fixnum))
- (eq translate 'eql))
- `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
- translate suffix))
- ,(intern
- (format nil "~:@(FAST-CONDITIONAL~A~)"
- suffix)))
- (:translate ,translate)
- (:generator ,cost
- (inst ,(if imm 'bci 'bc)
- ,(if signed signed-cond unsigned-cond)
- not-p
- ,(if (eq suffix '-c/fixnum)
- '(fixnumize y)
- 'y)
- x
- target)))))
- '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
- '(3 2 5 4 5 4)
- '(t t t t nil nil)
- '(nil t nil t nil t))))
+ (unless (and (member suffix '(/fixnum -c/fixnum))
+ (eq translate 'eql))
+ `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ translate suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,translate)
+ (:generator ,cost
+ (inst ,(if imm 'bci 'bc)
+ ,(if signed signed-cond unsigned-cond)
+ not-p
+ ,(if (eq suffix '-c/fixnum)
+ '(fixnumize y)
+ 'y)
+ x
+ target)))))
+ '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+ '(3 2 5 4 5 4)
+ '(t t t t nil nil)
+ '(nil t nil t nil t))))
;; We switch < and > because the immediate has to come first.
;;;
(define-vop (fast-eql/fixnum fast-conditional)
(:args (x :scs (any-reg descriptor-reg))
- (y :scs (any-reg)))
+ (y :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison")
(:translate eql)
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
(:arg-types * (:constant (signed-byte 9)))
(:variant-cost 6))
-
+
\f
;;;; modular functions
(define-modular-fun +-mod32 (x y) + :unsigned 32)
(:translate --mod32))
(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
- fast-ash-c/unsigned=>unsigned)
+ fast-ash-c/unsigned=>unsigned)
(:translate ash-left-mod32))
(define-vop (fast-ash-left-mod32/unsigned=>unsigned
- ;; FIXME: when FAST-ASH-LEFT/UNSIGNED=>UNSIGNED is
- ;; implemented, use it here. -- CSR, 2004-08-16
+ ;; FIXME: when FAST-ASH-LEFT/UNSIGNED=>UNSIGNED is
+ ;; implemented, use it here. -- CSR, 2004-08-16
fast-ash/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))
(macrolet
((define-modular-backend (fun)
(let ((mfun-name (symbolicate fun '-mod32))
- ;; FIXME: if anyone cares, add constant-arg vops. --
- ;; CSR, 2003-09-16
- (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
- (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
- `(progn
- (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
- (define-vop (,modvop ,vop)
- (:translate ,mfun-name))))))
+ ;; FIXME: if anyone cares, add constant-arg vops. --
+ ;; CSR, 2003-09-16
+ (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
+ (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
+ `(progn
+ (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
+ (define-vop (,modvop ,vop)
+ (:translate ,mfun-name))))))
(define-modular-backend logxor)
(define-modular-backend logandc1)
(define-modular-backend logandc2))
`(lognot (logand ,x ,y)))
(define-source-transform lognor (x y)
`(lognot (logior ,x y)))
-
+
(define-vop (shift-towards-someplace)
(:policy :fast-safe)
(:args (num :scs (unsigned-reg))
- (amount :scs (signed-reg)))
+ (amount :scs (signed-reg)))
(:arg-types unsigned-num tagged-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num))
(:translate sb!bignum:%add-with-carry)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
- (b :scs (unsigned-reg))
- (c :scs (unsigned-reg)))
+ (b :scs (unsigned-reg))
+ (c :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg))
- (carry :scs (unsigned-reg)))
+ (carry :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 3
(inst addi -1 c zero-tn)
(:translate sb!bignum:%subtract-with-borrow)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
- (b :scs (unsigned-reg))
- (c :scs (unsigned-reg)))
+ (b :scs (unsigned-reg))
+ (c :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg))
- (borrow :scs (unsigned-reg)))
+ (borrow :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 4
(inst addi -1 c zero-tn)
(:translate sb!bignum:%multiply)
(:policy :fast-safe)
(:args (x-arg :scs (unsigned-reg) :target x)
- (y-arg :scs (unsigned-reg) :target y))
+ (y-arg :scs (unsigned-reg) :target y))
(:arg-types unsigned-num unsigned-num)
(:temporary (:scs (signed-reg) :from (:argument 0)) x)
(:temporary (:scs (signed-reg) :from (:argument 1)) y)
(:temporary (:scs (signed-reg)) tmp)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 3
;; Make sure X is less then Y.
#+nil ;; This would be greate if it worked, but it doesn't.
(if (eql extra 0)
`(multiple-value-call #'sb!bignum:%dual-word-add
- (sb!bignum:%multiply ,x ,y)
- (values ,carry))
+ (sb!bignum:%multiply ,x ,y)
+ (values ,carry))
`(multiple-value-call #'sb!bignum:%dual-word-add
- (multiple-value-call #'sb!bignum:%dual-word-add
- (sb!bignum:%multiply ,x ,y)
- (values ,carry))
- (values ,extra)))
+ (multiple-value-call #'sb!bignum:%dual-word-add
+ (sb!bignum:%multiply ,x ,y)
+ (values ,carry))
+ (values ,extra)))
(with-unique-names (hi lo)
(if (eql extra 0)
- `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
- (sb!bignum::%dual-word-add ,hi ,lo ,carry))
- `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
- (multiple-value-bind
- (,hi ,lo)
- (sb!bignum::%dual-word-add ,hi ,lo ,carry)
- (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
+ `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
+ (sb!bignum::%dual-word-add ,hi ,lo ,carry))
+ `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
+ (multiple-value-bind
+ (,hi ,lo)
+ (sb!bignum::%dual-word-add ,hi ,lo ,carry)
+ (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
(defknown sb!bignum::%dual-word-add
- (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
+ (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
(values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
(flushable movable))
(:policy :fast-safe)
(:translate sb!bignum::%dual-word-add)
(:args (hi :scs (unsigned-reg) :to (:result 1))
- (lo :scs (unsigned-reg))
- (extra :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg))
+ (extra :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:results (hi-res :scs (unsigned-reg) :from (:result 1))
- (lo-res :scs (unsigned-reg) :from (:result 0)))
+ (lo-res :scs (unsigned-reg) :from (:result 0)))
(:result-types unsigned-num unsigned-num)
(:affected)
(:effects)
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (hi :scs (unsigned-reg) :to (:argument 1))
- (lo :scs (unsigned-reg) :to (:argument 0))
- (divisor :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg) :to (:argument 0))
+ (divisor :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
(:results (quo :scs (unsigned-reg) :from (:argument 0))
- (rem :scs (unsigned-reg) :from (:argument 1)))
+ (rem :scs (unsigned-reg) :from (:argument 1)))
(:result-types unsigned-num unsigned-num)
(:generator 65
(inst sub zero-tn divisor temp)
(:translate sb!bignum:%digit-logical-shift-right)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg))
- (count :scs (unsigned-reg)))
+ (count :scs (unsigned-reg)))
(:arg-types unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:translate make-array-header)
(:policy :fast-safe)
(:args (type :scs (any-reg))
- (rank :scs (any-reg)))
+ (rank :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
(:temporary (:scs (non-descriptor-reg) :type random) ndescr)
(: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))
(:results (result :scs (any-reg descriptor-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(let ((error (generate-error-code vop invalid-array-index-error
- array bound index)))
+ array bound index)))
(inst bc :>= nil index bound error))
(move index result)))
vector-data-offset other-pointer-lowtag ,scs ,element-type
data-vector-set)))
- (def-partial-data-vector-frobs
- (type element-type size signed &rest scs)
+ (def-partial-data-vector-frobs
+ (type element-type size signed &rest scs)
`(progn
(define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
,size ,signed vector-data-offset other-pointer-lowtag ,scs
:byte nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
:byte nil unsigned-reg signed-reg)
-
+
(def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
:short nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
:short nil unsigned-reg signed-reg)
-
+
(def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
unsigned-reg)
(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
unsigned-reg)
-
+
(def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
:byte t signed-reg)
-
+
(def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
:short t signed-reg)
-
+
(def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg)
(def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
-
+
(def-full-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg))
;;; 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))))
+ (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 (:scs (non-descriptor-reg)) temp)
- (:temporary (:scs (interior-reg)) lip)
- (:generator 20
- (inst srl index ,bit-shift temp)
- (inst sh2add temp object lip)
- (loadw result lip vector-data-offset other-pointer-lowtag)
- (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
- ,@(unless (= bits 1)
- `((inst addi ,(1- bits) temp temp)))
- (inst mtctl temp :sar)
- (inst extru result :variable ,bits result)))
+ (: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 (:scs (non-descriptor-reg)) temp)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (inst srl index ,bit-shift temp)
+ (inst sh2add temp object lip)
+ (loadw result lip vector-data-offset other-pointer-lowtag)
+ (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
+ ,@(unless (= bits 1)
+ `((inst addi ,(1- bits) temp temp)))
+ (inst mtctl temp :sar)
+ (inst extru result :variable ,bits result)))
(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)
- (:temporary (:scs (non-descriptor-reg)) temp)
- (:generator 15
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
- other-pointer-lowtag)))
- (cond ((typep offset '(signed-byte 14))
- (inst ldw offset object result))
- (t
- (inst ldil (ldb (byte 21 11) offset) temp)
- (inst ldw (ldb (byte 11 0) offset) temp result))))
- (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result))))
+ (: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)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 15
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 14))
+ (inst ldw offset object result))
+ (t
+ (inst ldil (ldb (byte 21 11) offset) temp)
+ (inst ldw (ldb (byte 11 0) offset) temp result))))
+ (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result))))
(define-vop (,(symbolicate 'data-vector-set/ type))
- (:note "inline array store")
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg))
- (value :scs (unsigned-reg zero immediate) :target result))
- (:arg-types ,type positive-fixnum positive-fixnum)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg)) temp old)
- (:temporary (:scs (interior-reg)) lip)
- (:generator 25
- (inst srl index ,bit-shift temp)
- (inst sh2add temp object lip)
- (loadw old lip vector-data-offset other-pointer-lowtag)
- (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
- ,@(unless (= bits 1)
- `((inst addi ,(1- bits) temp temp)))
- (inst mtctl temp :sar)
- (inst dep (sc-case value (immediate (tn-value value)) (t value))
- :variable ,bits old)
- (storew old lip vector-data-offset other-pointer-lowtag)
- (sc-case value
- (immediate
- (inst li (tn-value value) result))
- (t
- (move value result)))))
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg))
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type positive-fixnum positive-fixnum)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) temp old)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 25
+ (inst srl index ,bit-shift temp)
+ (inst sh2add temp object lip)
+ (loadw old lip vector-data-offset other-pointer-lowtag)
+ (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
+ ,@(unless (= bits 1)
+ `((inst addi ,(1- bits) temp temp)))
+ (inst mtctl temp :sar)
+ (inst dep (sc-case value (immediate (tn-value value)) (t value))
+ :variable ,bits old)
+ (storew old lip vector-data-offset other-pointer-lowtag)
+ (sc-case value
+ (immediate
+ (inst li (tn-value value) result))
+ (t
+ (move value result)))))
(define-vop (,(symbolicate 'data-vector-set-c/ type))
- (:translate data-vector-set)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (value :scs (unsigned-reg zero immediate) :target result))
- (:arg-types ,type
- (:constant index)
- positive-fixnum)
- (:info index)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg)) old)
- (:temporary (:scs (interior-reg)) lip)
- (:generator 20
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
- other-pointer-lowtag)))
- (cond ((typep offset '(signed-byte 14))
- (inst ldw offset object old))
- (t
- (inst move object lip)
- (inst addil (ldb (byte 21 11) offset) lip)
- (inst ldw (ldb (byte 11 0) offset) lip old)))
- (inst dep (sc-case value
- (immediate (tn-value value))
- (t value))
- (+ (* extra ,bits) ,(1- bits))
- ,bits
- old)
- (if (typep offset '(signed-byte 14))
- (inst stw old offset object)
- (inst stw old (ldb (byte 11 0) offset) lip)))
- (sc-case value
- (immediate
- (inst li (tn-value value) result))
- (t
- (move value result))))))))))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type
+ (:constant index)
+ positive-fixnum)
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) old)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 14))
+ (inst ldw offset object old))
+ (t
+ (inst move object lip)
+ (inst addil (ldb (byte 21 11) offset) lip)
+ (inst ldw (ldb (byte 11 0) offset) lip old)))
+ (inst dep (sc-case value
+ (immediate (tn-value value))
+ (t value))
+ (+ (* extra ,bits) ,(1- bits))
+ ,bits
+ old)
+ (if (typep offset '(signed-byte 14))
+ (inst stw old offset object)
+ (inst stw old (ldb (byte 11 0) offset) lip)))
+ (sc-case value
+ (immediate
+ (inst li (tn-value value) result))
+ (t
+ (move value result))))))))))
(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) :to (:argument 1))
- (index :scs (any-reg) :to (:argument 0) :target offset))
+ (index :scs (any-reg) :to (:argument 0) :target offset))
(:arg-types simple-array-single-float positive-fixnum)
(:results (value :scs (single-reg)))
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
(:result-types single-float)
(:generator 5
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- index offset)
+ index offset)
(inst fldx offset object value)))
(define-vop (data-vector-set/simple-array-single-float)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:argument 1))
- (index :scs (any-reg) :to (:argument 0) :target offset)
- (value :scs (single-reg) :target result))
+ (index :scs (any-reg) :to (:argument 0) :target offset)
+ (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)
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
(:generator 5
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- index offset)
+ index offset)
(inst fstx value offset object)
(unless (location= result value)
(inst funop :copy value result))))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:argument 1))
- (index :scs (any-reg) :to (:argument 0) :target offset))
+ (index :scs (any-reg) :to (:argument 0) :target offset))
(:arg-types simple-array-double-float positive-fixnum)
(:results (value :scs (double-reg)))
(:result-types double-float)
(:generator 7
(inst sll index 1 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- offset offset)
+ offset offset)
(inst fldx offset object value)))
(define-vop (data-vector-set/simple-array-double-float)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:argument 1))
- (index :scs (any-reg) :to (:argument 0) :target offset)
- (value :scs (double-reg) :target result))
+ (index :scs (any-reg) :to (:argument 0) :target offset)
+ (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 sll index 1 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- offset offset)
+ offset offset)
(inst fstx value offset object)
(unless (location= result value)
(inst funop :copy value result))))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-complex-single-float positive-fixnum)
(:results (value :scs (complex-single-reg)))
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(:generator 5
(inst sll index 1 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- offset offset)
+ offset offset)
(let ((real-tn (complex-single-reg-real-tn value)))
(inst fldx offset object real-tn))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (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)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(:generator 5
(inst sll index 1 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- offset offset)
+ offset offset)
(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 fstx value-real offset object)
(unless (location= result-real value-real)
- (inst funop :copy value-real result-real)))
+ (inst funop :copy value-real result-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 addi n-word-bytes offset offset)
(inst fstx value-imag offset object)
(unless (location= result-imag value-imag)
- (inst funop :copy value-imag result-imag)))))
+ (inst funop :copy value-imag result-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) :to :result)
- (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
(inst sll index 2 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- offset offset)
+ offset offset)
(let ((real-tn (complex-double-reg-real-tn value)))
(inst fldx offset object real-tn))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (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)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(:generator 20
(inst sll index 2 offset)
(inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- offset offset)
+ offset offset)
(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 fstx value-real offset object)
(unless (location= result-real value-real)
- (inst funop :copy value-real result-real)))
+ (inst funop :copy value-real result-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 addi (* 2 n-word-bytes) offset offset)
(inst fstx value-imag offset object)
(unless (location= result-imag value-imag)
- (inst funop :copy value-imag result-imag)))))
+ (inst funop :copy value-imag result-imag)))))
\f
;;; These VOPs are used for implementing float slots in structures (whose raw
(:translate %raw-set-double)
(:arg-types sb!c::raw-vector positive-fixnum double-float))
(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-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-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-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))
(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
(args 0))
(defstruct (arg-info
- (:constructor make-arg-info (offset prim-type reg-sc stack-sc)))
+ (:constructor make-arg-info (offset prim-type reg-sc stack-sc)))
offset
prim-type
reg-sc
(let ((args (arg-state-args state)))
(setf (arg-state-args state) (1+ args))
(if (alien-integer-type-signed type)
- (make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack)
- (make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))))
+ (make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack)
+ (make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))))
(define-alien-type-method (system-area-pointer :arg-tn) (type state)
(declare (ignore type))
(if (alien-integer-type-signed type)
(my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset)
(my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset)))
-
+
(define-alien-type-method (system-area-pointer :result-tn) (type)
(declare (ignore type))
(my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset))
(defun make-arg-tns (type)
(let* ((state (make-arg-state))
- (args (mapcar #'(lambda (arg-type)
- (invoke-alien-type-method :arg-tn arg-type state))
- (alien-fun-type-arg-types type)))
- ;; We need 8 words of cruft, and we need to round up to a multiple
- ;; of 16 words.
- (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15)))
+ (args (mapcar #'(lambda (arg-type)
+ (invoke-alien-type-method :arg-tn arg-type state))
+ (alien-fun-type-arg-types type)))
+ ;; We need 8 words of cruft, and we need to round up to a multiple
+ ;; of 16 words.
+ (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15)))
(values
(mapcar #'(lambda (arg)
- (declare (type arg-info arg))
- (let ((offset (arg-info-offset arg))
- (prim-type (arg-info-prim-type arg)))
- (cond ((>= offset 4)
- (my-make-wired-tn prim-type (arg-info-stack-sc arg)
- (- frame-size offset 8 1)))
- ((or (eq prim-type 'single-float)
- (eq prim-type 'double-float))
- (my-make-wired-tn prim-type (arg-info-reg-sc arg)
- (+ offset 4)))
- (t
- (my-make-wired-tn prim-type (arg-info-reg-sc arg)
- (- nl0-offset offset))))))
- args)
+ (declare (type arg-info arg))
+ (let ((offset (arg-info-offset arg))
+ (prim-type (arg-info-prim-type arg)))
+ (cond ((>= offset 4)
+ (my-make-wired-tn prim-type (arg-info-stack-sc arg)
+ (- frame-size offset 8 1)))
+ ((or (eq prim-type 'single-float)
+ (eq prim-type 'double-float))
+ (my-make-wired-tn prim-type (arg-info-reg-sc arg)
+ (+ offset 4)))
+ (t
+ (my-make-wired-tn prim-type (arg-info-reg-sc arg)
+ (- nl0-offset offset))))))
+ args)
(* frame-size n-word-bytes))))
(!def-vm-support-routine make-call-out-tns (type)
(arg-tns stack-size)
(make-arg-tns type)
(values (make-normal-tn *fixnum-primitive-type*)
- stack-size
- arg-tns
- (invoke-alien-type-method
- :result-tn
- (alien-fun-type-result-type type)))))
+ stack-size
+ arg-tns
+ (invoke-alien-type-method
+ :result-tn
+ (alien-fun-type-result-type type)))))
(define-vop (foreign-symbol-sap)
(:translate foreign-symbol-sap)
(define-vop (call-out)
(:args (function :scs (sap-reg) :target cfunc)
- (args :more t))
+ (args :more t))
(:results (results :more t))
(:ignore args results)
(:save-p t)
(:temporary (:sc any-reg :offset cfunc-offset
- :from (:argument 0) :to (:result 0)) cfunc)
+ :from (:argument 0) :to (:result 0)) cfunc)
(:temporary (:scs (any-reg) :to (:result 0)) temp)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:vop-var vop)
(:generator 0
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(move function cfunc)
(let ((fixup (make-fixup "call_into_c" :foreign)))
- (inst ldil fixup temp)
- (inst ble fixup c-text-space temp :nullify t))
+ (inst ldil fixup temp)
+ (inst ble fixup c-text-space temp :nullify t))
(inst nop)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))))
+ (load-stack-tn cur-nfp nfp-save)))))
(define-vop (alloc-number-stack-space)
(:info amount)
(move nsp-tn result)
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 63) 63)))
- (cond ((< delta (ash 1 10))
- (inst addi delta nsp-tn nsp-tn))
- (t
- (inst li delta temp)
- (inst add temp nsp-tn nsp-tn)))))))
+ (cond ((< delta (ash 1 10))
+ (inst addi delta nsp-tn nsp-tn))
+ (t
+ (inst li delta temp)
+ (inst add temp nsp-tn nsp-tn)))))))
(define-vop (dealloc-number-stack-space)
(:info amount)
(:generator 0
(unless (zerop amount)
(let ((delta (- (logandc2 (+ amount 63) 63))))
- (cond ((<= (- (ash 1 10)) delta)
- (inst addi delta nsp-tn nsp-tn))
- (t
- (inst li delta temp)
- (inst add temp nsp-tn nsp-tn)))))))
+ (cond ((<= (- (ash 1 10)) delta)
+ (inst addi delta nsp-tn nsp-tn))
+ (t
+ (inst li delta temp)
+ (inst add temp nsp-tn nsp-tn)))))))
(declare (type unsigned-byte n))
(if (< n register-arg-count)
(make-wired-tn *backend-t-primitive-type*
- register-arg-scn
- (elt *register-arg-offsets* n))
+ register-arg-scn
+ (elt *register-arg-offsets* n))
(make-wired-tn *backend-t-primitive-type*
- control-stack-arg-scn n)))
+ control-stack-arg-scn n)))
;;; Make a passing location TN for a local call return PC. If standard is
(specify-save-tn
(physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
(make-wired-tn *fixnum-primitive-type*
- control-stack-arg-scn
- ocfp-save-offset)))
+ control-stack-arg-scn
+ ocfp-save-offset)))
(!def-vm-support-routine make-return-pc-save-location (env)
(specify-save-tn
(physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env)
(make-wired-tn *backend-t-primitive-type*
- control-stack-arg-scn
- lra-save-offset)))
+ control-stack-arg-scn
+ lra-save-offset)))
;;; Make a TN for the standard argument count passing location. We only
;;; need to make the standard location, since a count is never passed when we
;;; 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
(declare (type component component))
(dotimes (i code-constants-offset)
(vector-push-extend nil
- (ir2-component-constants (component-info component))))
+ (ir2-component-constants (component-info component))))
(values))
\f
;;; We have to allocate multiples of 64 bytes.
(defun bytes-needed-for-non-descriptor-stack-frame ()
(logandc2 (+ (* (sb-allocated-size 'non-descriptor-stack) n-word-bytes) 63)
- 63))
+ 63))
;;; Used for setting up the Old-FP in local call.
;;;
(:generator 1
(let ((nfp (current-nfp-tn vop)))
(when nfp
- (inst addi (- (bytes-needed-for-non-descriptor-stack-frame))
- nfp val)))))
+ (inst addi (- (bytes-needed-for-non-descriptor-stack-frame))
+ nfp val)))))
(define-vop (xep-allocate-frame)
(:info start-lab copy-more-arg-follows)
(inst compute-code-from-fn lip-tn entry-point temp code-tn))
;; Build our stack frames.
(inst addi (* n-word-bytes (sb-allocated-size 'control-stack))
- cfp-tn csp-tn)
+ cfp-tn csp-tn)
(let ((nfp (current-nfp-tn vop)))
(when nfp
- (move nsp-tn nfp)
- (inst addi (bytes-needed-for-non-descriptor-stack-frame)
- nsp-tn nsp-tn)))
+ (move nsp-tn nfp)
+ (inst addi (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn nsp-tn)))
(trace-table-entry trace-table-normal)))
(define-vop (allocate-frame)
(:results (res :scs (any-reg))
- (nfp :scs (any-reg)))
+ (nfp :scs (any-reg)))
(:info callee)
(:generator 2
(move csp-tn res)
(inst addi (* n-word-bytes (sb-allocated-size 'control-stack))
- csp-tn csp-tn)
+ csp-tn csp-tn)
(when (ir2-physenv-number-stack-p callee)
(move nsp-tn nfp)
(inst addi (bytes-needed-for-non-descriptor-stack-frame)
- nsp-tn nsp-tn))))
+ nsp-tn nsp-tn))))
;;; Allocate a partial frame for passing stack arguments in a full call. Nargs
;;; is the number of arguments passed. If no stack arguments are passed, then
;;;
;;; The general-case code looks like this:
#|
- b regs-defaulted ; Skip if MVs
- nop
+ b regs-defaulted ; Skip if MVs
+ nop
- move a1 null-tn ; Default register values
- ...
- loadi nargs 1 ; Force defaulting of stack values
- move old-fp csp ; Set up args for SP resetting
+ move a1 null-tn ; Default register values
+ ...
+ loadi nargs 1 ; Force defaulting of stack values
+ move old-fp csp ; Set up args for SP resetting
regs-defaulted
- subu temp nargs register-arg-count
+ subu temp nargs register-arg-count
- bltz temp default-value-7 ; jump to default code
+ bltz temp default-value-7 ; jump to default code
addu temp temp -1
- loadw move-temp old-fp-tn 6 ; Move value to correct location.
- store-stack-tn val4-tn move-temp
+ loadw move-temp old-fp-tn 6 ; Move value to correct location.
+ store-stack-tn val4-tn move-temp
- bltz temp default-value-8
+ bltz temp default-value-8
addu temp temp -1
- loadw move-temp old-fp-tn 7
- store-stack-tn val5-tn move-temp
+ loadw move-temp old-fp-tn 7
+ store-stack-tn val5-tn move-temp
- ...
+ ...
defaulting-done
- move sp old-fp ; Reset SP.
+ move sp old-fp ; Reset SP.
<end of code>
<elsewhere>
default-value-7
- store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack)
+ store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack)
default-value-8
- store-stack-tn val5-tn null-tn ; Nil out 8'th value.
+ store-stack-tn val5-tn null-tn ; Nil out 8'th value.
- ...
+ ...
- br defaulting-done
+ br defaulting-done
nop
|#
;;;
(defun default-unknown-values (vop values nvals move-temp temp lra-label)
(declare (type (or tn-ref null) values)
- (type unsigned-byte nvals) (type tn move-temp temp))
+ (type unsigned-byte nvals) (type tn move-temp temp))
(cond
((<= nvals 1)
(assemble ()
(note-this-location vop :unknown-return)
;; Branch off to the MV case.
(inst b regs-defaulted :nullify t)
-
+
;; Default any unsupplied values.
(do ((val (tn-ref-across values) (tn-ref-across val)))
- ((null val))
- (inst move null-tn (tn-ref-tn val)
- (if (tn-ref-across val)
- :never
- :tr)))
+ ((null val))
+ (inst move null-tn (tn-ref-tn val)
+ (if (tn-ref-across val)
+ :never
+ :tr)))
REGS-DEFAULTED
(t
(collect ((defaults))
(assemble (nil nil :labels (default-stack-vals))
- ;; Note that this is an unknown-values return point.
- (note-this-location vop :unknown-return)
- ;; Branch off to the MV case.
- (inst b regs-defaulted :nullify t)
-
- ;; Default any unsupplied register values.
- (do ((i 1 (1+ i))
- (val (tn-ref-across values) (tn-ref-across val)))
- ((= i register-arg-count))
- (inst move null-tn (tn-ref-tn val)))
- (inst b default-stack-vals)
- (move ocfp-tn csp-tn)
-
- REGS-DEFAULTED
-
- (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 bci :>= nil (fixnumize i) nargs-tn default-lab)
- (loadw move-temp ocfp-tn i)
- (store-stack-tn tn move-temp)))
-
- DEFAULTING-DONE
- (move ocfp-tn csp-tn)
- (inst compute-code-from-lra code-tn lra-label temp code-tn)
-
- (let ((defaults (defaults)))
- (aver defaults)
- (assemble (*elsewhere*)
- (trace-table-entry trace-table-call-site)
- DEFAULT-STACK-VALS
- (do ((remaining defaults (cdr remaining)))
- ((null remaining))
- (let ((def (car remaining)))
- (emit-label (car def))
- (when (null (cdr remaining))
- (inst b defaulting-done))
- (store-stack-tn (cdr def) null-tn)))
- (trace-table-entry trace-table-normal)))))))
+ ;; Note that this is an unknown-values return point.
+ (note-this-location vop :unknown-return)
+ ;; Branch off to the MV case.
+ (inst b regs-defaulted :nullify t)
+
+ ;; Default any unsupplied register values.
+ (do ((i 1 (1+ i))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i register-arg-count))
+ (inst move null-tn (tn-ref-tn val)))
+ (inst b default-stack-vals)
+ (move ocfp-tn csp-tn)
+
+ REGS-DEFAULTED
+
+ (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 bci :>= nil (fixnumize i) nargs-tn default-lab)
+ (loadw move-temp ocfp-tn i)
+ (store-stack-tn tn move-temp)))
+
+ DEFAULTING-DONE
+ (move ocfp-tn csp-tn)
+ (inst compute-code-from-lra code-tn lra-label temp code-tn)
+
+ (let ((defaults (defaults)))
+ (aver defaults)
+ (assemble (*elsewhere*)
+ (trace-table-entry trace-table-call-site)
+ DEFAULT-STACK-VALS
+ (do ((remaining defaults (cdr remaining)))
+ ((null remaining))
+ (let ((def (car remaining)))
+ (emit-label (car def))
+ (when (null (cdr remaining))
+ (inst b defaulting-done))
+ (store-stack-tn (cdr def) null-tn)))
+ (trace-table-entry trace-table-normal)))))))
(values))
\f
(declare (type tn args nargs start count temp))
(assemble (nil nil :labels (variable-values))
(inst b variable-values :nullify t)
-
+
(inst compute-code-from-lra code-tn lra-label temp code-tn)
(inst move csp-tn start)
(inst stwm (first register-arg-tns) n-word-bytes csp-tn)
(inst li (fixnumize 1) count)
-
+
DONE
-
+
(assemble (*elsewhere*)
(trace-table-entry trace-table-call-site)
VARIABLE-VALUES
(inst compute-code-from-lra code-tn lra-label temp code-tn)
(do ((arg register-arg-tns (rest arg))
- (i 0 (1+ i)))
- ((null arg))
- (storew (first arg) args i))
+ (i 0 (1+ i)))
+ ((null arg))
+ (storew (first arg) args i))
(move args start)
(move nargs count)
(inst b done :nullify t)
;;;
(define-vop (unknown-values-receiver)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:temporary (:sc descriptor-reg :offset ocfp-offset
- :from :eval :to (:result 0))
- values-start)
+ :from :eval :to (:result 0))
+ values-start)
(:temporary (:sc any-reg :offset nargs-offset
- :from :eval :to (:result 1))
- nvals)
+ :from :eval :to (:result 1))
+ nvals)
(:temporary (:scs (non-descriptor-reg)) temp))
;;;
(define-vop (call-local)
(:args (cfp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:results (values :more t))
(:save-p t)
(:move-args :local-call)
(:generator 5
(trace-table-entry trace-table-call-site)
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn cfp)
(inst compute-lra-from-code code-tn label temp
- (callee-return-pc-tn callee))
+ (callee-return-pc-tn callee))
(note-this-location vop :call-site)
(inst b target :nullify t)
(emit-return-pc label)
(default-unknown-values vop values nvals move-temp temp label)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))
+ (load-stack-tn cur-nfp nfp-save)))
(trace-table-entry trace-table-normal)))
;;; Non-TR local call for a variable number of return values passed according
;;;
(define-vop (multiple-call-local unknown-values-receiver)
(:args (cfp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:save-p t)
(:move-args :local-call)
(:info save callee target)
(:generator 20
(trace-table-entry trace-table-call-site)
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn cfp)
(inst compute-lra-from-code code-tn label temp
- (callee-return-pc-tn callee))
+ (callee-return-pc-tn callee))
(note-this-location vop :call-site)
(inst b target :nullify t)
(emit-return-pc label)
(note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count label temp)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))
+ (load-stack-tn cur-nfp nfp-save)))
(trace-table-entry trace-table-normal)))
\f
;;;
(define-vop (known-call-local)
(:args (cfp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:results (res :more t))
(:move-args :local-call)
(:save-p t)
(:generator 5
(trace-table-entry trace-table-call-site)
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn cfp)
(inst compute-lra-from-code code-tn label temp
- (callee-return-pc-tn callee))
+ (callee-return-pc-tn callee))
(note-this-location vop :call-site)
(inst b target :nullify t)
(emit-return-pc label)
(note-this-location vop :known-return)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))
+ (load-stack-tn cur-nfp nfp-save)))
(trace-table-entry trace-table-normal)))
;;; Return from known values call. We receive the return locations as
;;;
(define-vop (known-return)
(:args (old-fp :target old-fp-temp)
- (return-pc :target return-pc-temp)
- (vals :more t))
+ (return-pc :target return-pc-temp)
+ (vals :more t))
(:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
(:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
(:temporary (:scs (interior-reg)) lip)
(move cfp-tn csp-tn)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (move cur-nfp nsp-tn)))
+ (move cur-nfp nsp-tn)))
(inst addi (- n-word-bytes other-pointer-lowtag) return-pc-temp lip)
(inst bv lip)
(move old-fp-temp cfp-tn)
;;; replication in defining the cross-product VOPs.
;;;
;;; Name is the name of the VOP to define.
-;;;
+;;;
;;; Named is true if the first argument is a symbol whose global function
;;; definition is to be called.
;;;
(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)))
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
(:args
,@(unless (eq return :tail)
- '((new-fp :scs (any-reg) :to :eval)))
+ '((new-fp :scs (any-reg) :to :eval)))
,(if named
- '(fdefn :target fdefn-pass)
- '(arg-fun :target lexenv))
-
+ '(fdefn :target fdefn-pass)
+ '(arg-fun :target lexenv))
+
,@(when (eq return :tail)
- '((ocfp :target ocfp-pass)
- (lra :target lra-pass)))
-
+ '((ocfp :target ocfp-pass)
+ (lra :target lra-pass)))
+
,@(unless variable '((args :more t :scs (descriptor-reg)))))
,@(when (eq return :fixed)
- '((:results (values :more t))))
-
+ '((:results (values :more t))))
+
(:save-p ,(if (eq return :tail) :compute-only t))
,@(unless (or (eq return :tail) variable)
- '((:move-args :full-call)))
+ '((:move-args :full-call)))
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(unless variable '(nargs))
+ ,@(when (eq return :fixed) '(nvals)))
(:ignore
,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(args)))
(:temporary (:sc descriptor-reg
- :offset ocfp-offset
- ,@(when (eq return :tail)
- '(:from (:argument 1)))
- ,@(unless (eq return :fixed)
- '(:to :eval)))
- ocfp-pass)
+ :offset ocfp-offset
+ ,@(when (eq return :tail)
+ '(:from (:argument 1)))
+ ,@(unless (eq return :fixed)
+ '(:to :eval)))
+ ocfp-pass)
(:temporary (:sc descriptor-reg
- :offset lra-offset
- ,@(when (eq return :tail)
- '(:from (:argument 2)))
- :to :eval)
- lra-pass)
+ :offset lra-offset
+ ,@(when (eq return :tail)
+ '(:from (:argument 2)))
+ :to :eval)
+ lra-pass)
,@(if named
- `((:temporary (:sc descriptor-reg :offset fdefn-offset
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- fdefn-pass))
-
- `((:temporary (:sc descriptor-reg :offset lexenv-offset
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- lexenv)
- (:temporary (:scs (descriptor-reg)
- :from (:argument ,(if (eq return :tail) 2 1))
- :to :eval)
- function)))
+ `((:temporary (:sc descriptor-reg :offset fdefn-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ fdefn-pass))
+
+ `((:temporary (:sc descriptor-reg :offset lexenv-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ lexenv)
+ (:temporary (:scs (descriptor-reg)
+ :from (:argument ,(if (eq return :tail) 2 1))
+ :to :eval)
+ function)))
(:temporary (:sc any-reg :offset nargs-offset :to :eval)
- nargs-pass)
+ nargs-pass)
,@(when variable
- (mapcar #'(lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :to :eval)
- ,name))
- register-arg-names *register-arg-offsets*))
+ (mapcar #'(lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :to :eval)
+ ,name))
+ register-arg-names *register-arg-offsets*))
,@(when (eq return :fixed)
- '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+ '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
,@(unless (eq return :tail)
- '((:temporary (:scs (non-descriptor-reg)) temp)
- (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+ '((:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
(:temporary (:scs (interior-reg) :type interior) lip)
(:generator ,(+ (if named 5 0)
- (if variable 19 1)
- (if (eq return :tail) 0 10)
- 15
- (if (eq return :unknown) 25 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)
(let* ((cur-nfp (current-nfp-tn vop))
- ,@(unless (eq return :tail)
- '((lra-label (gen-label))))
- (filler
- (list :load-nargs
- ,@(if (eq return :tail)
- '((unless (location= ocfp ocfp-pass)
- :load-ocfp)
- (unless (location= lra lra-pass)
- :load-lra)
- (when cur-nfp
- :frob-nfp))
- '((when cur-nfp
- :frob-nfp)
- :comp-lra
- :save-fp
- :load-fp)))))
- (labels
- ((do-next-filler ()
- (when filler
- (ecase (pop filler)
- ((nil) (do-next-filler))
- (:load-nargs
- ,@(if variable
- `((inst sub csp-tn new-fp nargs-pass)
- ,@(let ((index -1))
- (mapcar #'(lambda (name)
- `(loadw ,name new-fp
- ,(incf index)))
- register-arg-names)))
- '((inst li (fixnumize nargs) nargs-pass))))
- ,@(if (eq return :tail)
- '((:load-ocfp
- (sc-case ocfp
- (any-reg
- (inst move ocfp ocfp-pass))
- (control-stack
- (loadw ocfp-pass cfp-tn (tn-offset ocfp)))))
- (:load-lra
- (sc-case lra
- (descriptor-reg
- (inst move lra lra-pass))
- (control-stack
- (loadw lra-pass cfp-tn (tn-offset lra)))))
- (:frob-nfp
- (inst move cur-nfp nsp-tn)))
- `((:frob-nfp
- (store-stack-tn nfp-save cur-nfp))
- (:comp-lra
- (inst compute-lra-from-code
- code-tn lra-label temp lra-pass))
- (:save-fp
- (inst move cfp-tn ocfp-pass))
- (:load-fp
- ,(if variable
- '(move new-fp cfp-tn)
- '(if (> nargs register-arg-count)
- (move new-fp cfp-tn)
- (move csp-tn cfp-tn))))))))))
-
- ,@(if named
- `((sc-case fdefn
- (descriptor-reg (move fdefn fdefn-pass))
- (control-stack
- (loadw fdefn-pass cfp-tn (tn-offset fdefn))
- (do-next-filler))
- (constant
- (loadw fdefn-pass code-tn (tn-offset fdefn)
- other-pointer-lowtag)
- (do-next-filler)))
- (loadw lip fdefn-pass fdefn-raw-addr-slot
- other-pointer-lowtag)
- (do-next-filler))
- `((sc-case arg-fun
- (descriptor-reg (move arg-fun lexenv))
- (control-stack
- (loadw lexenv cfp-tn (tn-offset arg-fun))
- (do-next-filler))
- (constant
- (loadw lexenv code-tn (tn-offset arg-fun)
- other-pointer-lowtag)
- (do-next-filler)))
- (loadw function lexenv closure-fun-slot
- fun-pointer-lowtag)
- (do-next-filler)
- (inst addi (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag)
- function lip)))
- (loop
- (cond ((null filler)
- (return))
- ((null (car filler))
- (pop filler))
- ((null (cdr filler))
- (return))
- (t
- (do-next-filler))))
-
- (note-this-location vop :call-site)
- (inst bv lip :nullify (null filler))
- (do-next-filler))
-
- ,@(ecase return
- (:fixed
- '((emit-return-pc lra-label)
- (default-unknown-values vop values nvals
- move-temp temp lra-label)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:unknown
- '((emit-return-pc lra-label)
- (note-this-location vop :unknown-return)
- (receive-unknown-values values-start nvals start count
- lra-label temp)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:tail)))
+ ,@(unless (eq return :tail)
+ '((lra-label (gen-label))))
+ (filler
+ (list :load-nargs
+ ,@(if (eq return :tail)
+ '((unless (location= ocfp ocfp-pass)
+ :load-ocfp)
+ (unless (location= lra lra-pass)
+ :load-lra)
+ (when cur-nfp
+ :frob-nfp))
+ '((when cur-nfp
+ :frob-nfp)
+ :comp-lra
+ :save-fp
+ :load-fp)))))
+ (labels
+ ((do-next-filler ()
+ (when filler
+ (ecase (pop filler)
+ ((nil) (do-next-filler))
+ (:load-nargs
+ ,@(if variable
+ `((inst sub csp-tn new-fp nargs-pass)
+ ,@(let ((index -1))
+ (mapcar #'(lambda (name)
+ `(loadw ,name new-fp
+ ,(incf index)))
+ register-arg-names)))
+ '((inst li (fixnumize nargs) nargs-pass))))
+ ,@(if (eq return :tail)
+ '((:load-ocfp
+ (sc-case ocfp
+ (any-reg
+ (inst move ocfp ocfp-pass))
+ (control-stack
+ (loadw ocfp-pass cfp-tn (tn-offset ocfp)))))
+ (:load-lra
+ (sc-case lra
+ (descriptor-reg
+ (inst move lra lra-pass))
+ (control-stack
+ (loadw lra-pass cfp-tn (tn-offset lra)))))
+ (:frob-nfp
+ (inst move cur-nfp nsp-tn)))
+ `((:frob-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (:comp-lra
+ (inst compute-lra-from-code
+ code-tn lra-label temp lra-pass))
+ (:save-fp
+ (inst move cfp-tn ocfp-pass))
+ (:load-fp
+ ,(if variable
+ '(move new-fp cfp-tn)
+ '(if (> nargs register-arg-count)
+ (move new-fp cfp-tn)
+ (move csp-tn cfp-tn))))))))))
+
+ ,@(if named
+ `((sc-case fdefn
+ (descriptor-reg (move fdefn fdefn-pass))
+ (control-stack
+ (loadw fdefn-pass cfp-tn (tn-offset fdefn))
+ (do-next-filler))
+ (constant
+ (loadw fdefn-pass code-tn (tn-offset fdefn)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw lip fdefn-pass fdefn-raw-addr-slot
+ other-pointer-lowtag)
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move arg-fun lexenv))
+ (control-stack
+ (loadw lexenv cfp-tn (tn-offset arg-fun))
+ (do-next-filler))
+ (constant
+ (loadw lexenv code-tn (tn-offset arg-fun)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw function lexenv closure-fun-slot
+ fun-pointer-lowtag)
+ (do-next-filler)
+ (inst addi (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag)
+ function lip)))
+ (loop
+ (cond ((null filler)
+ (return))
+ ((null (car filler))
+ (pop filler))
+ ((null (cdr filler))
+ (return))
+ (t
+ (do-next-filler))))
+
+ (note-this-location vop :call-site)
+ (inst bv lip :nullify (null filler))
+ (do-next-filler))
+
+ ,@(ecase return
+ (:fixed
+ '((emit-return-pc lra-label)
+ (default-unknown-values vop values nvals
+ move-temp temp lra-label)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:unknown
+ '((emit-return-pc lra-label)
+ (note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count
+ lra-label temp)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:tail)))
(trace-table-entry trace-table-normal)))))
(define-full-call call nil :fixed nil)
(define-full-call multiple-call-named t :unknown nil)
(define-full-call tail-call nil :tail nil)
(define-full-call tail-call-named t :tail nil)
-
+
(define-full-call call-variable nil :fixed t)
(define-full-call multiple-call-variable nil :unknown t))
-
-
+
+
;;; Defined separately, since needs special code that BLT's the arguments
;;; down.
;;;
(define-vop (tail-call-variable)
(:args (args-arg :scs (any-reg) :target args)
- (function-arg :scs (descriptor-reg) :target lexenv)
- (old-fp-arg :scs (any-reg) :target old-fp)
- (lra-arg :scs (descriptor-reg) :target lra))
+ (function-arg :scs (descriptor-reg) :target lexenv)
+ (old-fp-arg :scs (any-reg) :target old-fp)
+ (lra-arg :scs (descriptor-reg) :target lra))
(:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
(:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
;; Clear the number stack if anything is there.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst move cur-nfp nsp-tn)))
+ (inst move cur-nfp nsp-tn)))
;; And jump to the assembly-routine that does the bliting.
(let ((fixup (make-fixup 'tail-call-variable :assembly-routine)))
;;;; Unknown values return:
;;; Return a single value using the unknown-values convention.
-;;;
+;;;
(define-vop (return-single)
(:args (old-fp :scs (any-reg))
- (return-pc :scs (descriptor-reg))
- (value))
+ (return-pc :scs (descriptor-reg))
+ (value))
(:ignore value)
(:vop-var vop)
(:generator 6
(trace-table-entry trace-table-fun-epilogue)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst move cur-nfp nsp-tn)))
+ (inst move cur-nfp nsp-tn)))
;; Clear the control stack, and restore the frame pointer.
(move cfp-tn csp-tn)
(move old-fp cfp-tn)
(trace-table-entry trace-table-fun-epilogue)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst move cur-nfp nsp-tn)))
+ (inst move cur-nfp nsp-tn)))
;; Establish the values pointer and values count.
(move cfp-tn val-ptr)
(inst li (fixnumize nvals) nargs)
;; pre-default any argument register that need it.
(when (< nvals register-arg-count)
(dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
- (move null-tn reg)))
+ (move null-tn reg)))
;; And away we go.
(lisp-return return-pc)
(trace-table-entry trace-table-normal)))
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst move cur-nfp nsp-tn)))
+ (inst move cur-nfp nsp-tn)))
(unless (policy node (> space speed))
;; Check for the single case.
(move cfp-tn csp-tn)
(move old-fp-arg cfp-tn)
(lisp-return lra-arg :offset 1))
-
+
;; Nope, not the single case.
NOT-SINGLE
(move old-fp-arg old-fp)
;;;
(define-vop (setup-closure-environment)
(:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
- :to (:result 0))
- lexenv)
+ :to (:result 0))
+ lexenv)
(:results (closure :scs (descriptor-reg)))
(:info label)
(:ignore label)
(move lexenv closure)))
;;; Copy a more arg from the argument area to the end of the current frame.
-;;; Fixed is the number of non-more arguments.
+;;; Fixed is the number of non-more arguments.
;;;
(define-vop (copy-more-arg)
(:temporary (:sc any-reg :offset nl0-offset) result)
;; branched to done up at the top.
(inst addi (fixnumize (- fixed)) nargs-tn count)
(do ((i fixed (1+ i)))
- ((>= i register-arg-count))
- ;; Is this the last one?
- (inst addib :<= (fixnumize -1) count done)
- ;; Store it relative to the pointer saved at the start.
- (storew (nth i register-arg-tns) result (- i fixed))))
+ ((>= i register-arg-count))
+ ;; Is this the last one?
+ (inst addib :<= (fixnumize -1) count done)
+ ;; Store it relative to the pointer saved at the start.
+ (storew (nth i register-arg-tns) result (- i fixed))))
DONE))
;;; More args are stored consequtively on the stack, starting immediately at
;;;
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
- (count-arg :target count :scs (any-reg)))
+ (count-arg :target count :scs (any-reg)))
(:arg-types * tagged-num)
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
;; We need to do this atomically.
(pseudo-atomic ()
(assemble ()
- ;; Allocate a cons (2 words) for each item.
- (inst move alloc-tn result)
- (inst dep list-pointer-lowtag 31 3 result)
- (move result dst)
- (inst sll count 1 temp)
- (inst add alloc-tn temp alloc-tn)
-
- LOOP
- ;; Grab one value and stash it in the car of this cons.
- (inst ldwm n-word-bytes context temp)
- (storew temp dst 0 list-pointer-lowtag)
-
- ;; Dec count, and if != zero, go back for more.
- (inst addi (* 2 n-word-bytes) dst dst)
- (inst addib :> (fixnumize -1) count loop :nullify t)
- (storew dst dst -1 list-pointer-lowtag)
-
- ;; NIL out the last cons.
- (storew null-tn dst -1 list-pointer-lowtag)
- ;; Clear out dst, because it points past the last cons.
- (move null-tn dst)))
+ ;; Allocate a cons (2 words) for each item.
+ (inst move alloc-tn result)
+ (inst dep list-pointer-lowtag 31 3 result)
+ (move result dst)
+ (inst sll count 1 temp)
+ (inst add alloc-tn temp alloc-tn)
+
+ LOOP
+ ;; Grab one value and stash it in the car of this cons.
+ (inst ldwm n-word-bytes context temp)
+ (storew temp dst 0 list-pointer-lowtag)
+
+ ;; Dec count, and if != zero, go back for more.
+ (inst addi (* 2 n-word-bytes) dst dst)
+ (inst addib :> (fixnumize -1) count loop :nullify t)
+ (storew dst dst -1 list-pointer-lowtag)
+
+ ;; NIL out the last cons.
+ (storew null-tn dst -1 list-pointer-lowtag)
+ ;; Clear out dst, because it points past the last cons.
+ (move null-tn dst)))
DONE))
;;; Return the location and size of the more arg glob created by Copy-More-Arg.
(:arg-types tagged-num (: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
(: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)))
(cond ((zerop count)
- (inst bc :<> nil nargs zero-tn err-lab))
- (t
- (inst bci :<> nil (fixnumize count) nargs err-lab))))))
+ (inst bc :<> nil nargs zero-tn err-lab))
+ (t
+ (inst bci :<> nil (fixnumize count) nargs err-lab))))))
;;; Signal an argument count error.
;;;
(macrolet ((frob (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)))))
(frob arg-count-error invalid-arg-count-error
sb!c::%arg-count-error nargs)
(frob 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)))
+ (value :scs (descriptor-reg any-reg)))
(:info name offset lowtag)
(:ignore name)
(:results)
(:policy :fast-safe)
(:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
- (fdefn :scs (descriptor-reg)))
+ (fdefn :scs (descriptor-reg)))
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg)) type)
(:results (result :scs (descriptor-reg)))
(inst addi (- simple-fun-header-widetag) type type)
(inst comb := type zero-tn normal-fn)
(inst addi (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
- function lip)
+ function lip)
(inst li (make-fixup "closure_tramp" :foreign) lip)
NORMAL-FN
(storew function fdefn fdefn-fun-slot other-pointer-lowtag)
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
- (symbol :scs (descriptor-reg)))
+ (symbol :scs (descriptor-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:generator 5
(loadw temp symbol symbol-value-slot other-pointer-lowtag)
;;; 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)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:effects)
(:affected)
(:generator 0
;;; Move untagged character args/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))
(:generator 0
(sc-case y
;;; Comparison of characters.
(define-vop (character-compare)
(:args (x :scs (character-reg))
- (y :scs (character-reg)))
+ (y :scs (character-reg)))
(:arg-types character character)
(:conditional)
(:info target not-p)
(:translate stack-ref)
(:policy :fast-safe)
(:args (object :scs (sap-reg))
- (offset :scs (any-reg)))
+ (offset :scs (any-reg)))
(:arg-types system-area-pointer positive-fixnum)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:translate %set-stack-ref)
(:policy :fast-safe)
(:args (object :scs (sap-reg) :target sap)
- (offset :scs (any-reg))
- (value :scs (descriptor-reg) :target result))
+ (offset :scs (any-reg))
+ (value :scs (descriptor-reg) :target result))
(:arg-types system-area-pointer positive-fixnum *)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(: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 offset)
(:arg-types system-area-pointer (:constant (signed-byte 12)) *)
(:results (result :scs (descriptor-reg)))
(defun ld-float (offset base r)
(cond ((< offset (ash 1 4))
- (inst flds offset base r))
- (t
- (inst ldo offset zero-tn lip-tn)
- (inst fldx lip-tn base r))))
+ (inst flds offset base r))
+ (t
+ (inst ldo offset zero-tn lip-tn)
+ (inst fldx lip-tn base r))))
(define-move-fun (load-float 1) (vop x y)
((single-stack) (single-reg)
(defun str-float (x offset base)
(cond ((< offset (ash 1 4))
- (inst fsts x offset base))
- (t
- (inst ldo offset zero-tn lip-tn)
- (inst fstx x lip-tn base))))
+ (inst fsts x offset base))
+ (t
+ (inst ldo offset zero-tn lip-tn)
+ (inst fstx x lip-tn base))))
(define-move-fun (store-float 1) (vop x y)
((single-reg) (single-stack)
;;;; Move VOPs
(define-vop (move-float)
(:args (x :scs (single-reg double-reg)
- :target y
- :load-if (not (location= x y))))
+ :target y
+ :load-if (not (location= x y))))
(:results (y :scs (single-reg double-reg)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:note "float move")
(:generator 0
(unless (location= y x)
(inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y))))
(macrolet ((frob (name sc &rest args)
- `(progn
- (define-vop (,name move-from-float)
- (:args (x :scs (,sc) :to :save))
- (:variant ,@args))
- (define-move-vop ,name :move (,sc) (descriptor-reg)))))
+ `(progn
+ (define-vop (,name move-from-float)
+ (:args (x :scs (,sc) :to :save))
+ (:variant ,@args))
+ (define-move-vop ,name :move (,sc) (descriptor-reg)))))
(frob move-from-single single-reg
single-float-size single-float-widetag single-float-value-slot)
(frob move-from-double double-reg
(inst flds (- (* offset n-word-bytes) other-pointer-lowtag) x y)))
(macrolet ((frob (name sc offset)
- `(progn
- (define-vop (,name move-to-float)
- (:results (y :scs (,sc)))
- (:variant ,offset))
- (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name move-to-float)
+ (:results (y :scs (,sc)))
+ (:variant ,offset))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-single single-reg single-float-value-slot)
(frob move-to-double double-reg double-float-value-slot))
(define-vop (move-float-arg)
(:args (x :scs (single-reg double-reg) :target y)
- (nfp :scs (any-reg)
- :load-if (not (sc-is y single-reg double-reg))))
+ (nfp :scs (any-reg)
+ :load-if (not (sc-is y single-reg double-reg))))
(:results (y))
(:note "float argument move")
(:generator 1
(sc-case y
((single-reg double-reg)
(unless (location= x y)
- (inst funop :copy x y)))
+ (inst funop :copy x y)))
((single-stack double-stack)
(let ((offset (* (tn-offset y) n-word-bytes)))
- (str-float x offset nfp))))))
+ (str-float x offset nfp))))))
(define-move-vop move-float-arg :move-arg
(single-reg descriptor-reg) (single-reg))
(define-move-vop move-float-arg :move-arg
;;;; Complex float move functions
(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))))
(define-move-fun (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(let ((real-tn (complex-single-reg-real-tn y)))
(ld-float offset nfp real-tn))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(ld-float (+ offset n-word-bytes) nfp imag-tn))))
-
+
(define-move-fun (store-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(let ((real-tn (complex-single-reg-real-tn x)))
(str-float real-tn offset nfp))
(let ((imag-tn (complex-single-reg-imag-tn x)))
(define-move-fun (load-complex-double 4) (vop x y)
((complex-double-stack) (complex-double-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(let ((real-tn (complex-double-reg-real-tn y)))
(ld-float offset nfp real-tn))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(define-move-fun (store-complex-double 4) (vop x y)
((complex-double-reg) (complex-double-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(let ((real-tn (complex-double-reg-real-tn x)))
(str-float real-tn offset nfp))
(let ((imag-tn (complex-double-reg-imag-tn x)))
;;; Complex float register to register moves.
(define-vop (complex-single-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))))
(:note "complex single float move")
(:generator 0
;; 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-single-reg-real-tn x))
- (y-real (complex-single-reg-real-tn y)))
- (inst funop :copy x-real y-real))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst funop :copy x-real y-real))
(let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst funop :copy x-imag y-imag)))))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst funop :copy x-imag y-imag)))))
(define-move-vop complex-single-move :move
(complex-single-reg) (complex-single-reg))
(define-vop (complex-double-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))))
(:note "complex double float move")
(:generator 0
;; 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)))
- (inst funop :copy x-real y-real))
+ (y-real (complex-double-reg-real-tn y)))
+ (inst funop :copy x-real y-real))
(let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (inst funop :copy x-imag y-imag)))))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst funop :copy x-imag y-imag)))))
(define-move-vop complex-double-move :move
(complex-double-reg) (complex-double-reg))
(:note "complex single float to pointer coercion")
(:generator 13
(with-fixed-allocation (y ndescr complex-single-float-widetag
- complex-single-float-size)
+ complex-single-float-size)
(let ((real-tn (complex-single-reg-real-tn x)))
(inst fsts real-tn (- (* complex-single-float-real-slot n-word-bytes)
other-pointer-lowtag)
(:note "complex double float to pointer coercion")
(:generator 13
(with-fixed-allocation (y ndescr complex-double-float-widetag
- complex-double-float-size)
+ complex-double-float-size)
(let ((real-tn (complex-double-reg-real-tn x)))
(inst fsts real-tn (- (* complex-double-float-real-slot n-word-bytes)
other-pointer-lowtag)
(:generator 2
(let ((real-tn (complex-single-reg-real-tn y)))
(inst flds (- (* complex-single-float-real-slot n-word-bytes)
- other-pointer-lowtag)
- x real-tn))
+ other-pointer-lowtag)
+ x real-tn))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(inst flds (- (* complex-single-float-imag-slot n-word-bytes)
- other-pointer-lowtag)
- x imag-tn))))
+ other-pointer-lowtag)
+ x imag-tn))))
(define-move-vop move-to-complex-single :move
(descriptor-reg) (complex-single-reg))
(:generator 2
(let ((real-tn (complex-double-reg-real-tn y)))
(inst flds (- (* complex-double-float-real-slot n-word-bytes)
- other-pointer-lowtag)
- x real-tn))
+ other-pointer-lowtag)
+ x real-tn))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(inst flds (- (* complex-double-float-imag-slot n-word-bytes)
- other-pointer-lowtag)
- x imag-tn))))
+ other-pointer-lowtag)
+ x imag-tn))))
(define-move-vop move-to-complex-double :move
(descriptor-reg) (complex-double-reg))
;;; Complex float move-arg vop
(define-vop (move-complex-single-float-arg)
(:args (x :scs (complex-single-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
(:results (y))
(:note "float argument move")
(:generator 1
(sc-case y
(complex-single-reg
(unless (location= x y)
- (let ((x-real (complex-single-reg-real-tn x))
- (y-real (complex-single-reg-real-tn y)))
- (inst funop :copy x-real y-real))
- (let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst funop :copy x-imag y-imag))))
+ (let ((x-real (complex-single-reg-real-tn x))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst funop :copy x-real y-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst funop :copy x-imag y-imag))))
(complex-single-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-single-reg-real-tn x)))
- (str-float real-tn offset nfp))
- (let ((imag-tn (complex-single-reg-imag-tn x)))
- (str-float imag-tn (+ offset n-word-bytes) nfp)))))))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (str-float real-tn offset nfp))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (str-float imag-tn (+ offset n-word-bytes) nfp)))))))
(define-move-vop move-complex-single-float-arg :move-arg
(complex-single-reg descriptor-reg) (complex-single-reg))
(define-vop (move-complex-double-float-arg)
(:args (x :scs (complex-double-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
(:results (y))
(:note "float argument move")
(:generator 1
(sc-case y
(complex-double-reg
(unless (location= x y)
- (let ((x-real (complex-double-reg-real-tn x))
- (y-real (complex-double-reg-real-tn y)))
- (inst funop :copy x-real y-real))
- (let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (inst funop :copy x-imag y-imag))))
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (inst funop :copy x-real y-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst funop :copy x-imag y-imag))))
(complex-double-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-double-reg-real-tn x)))
- (str-float real-tn offset nfp))
- (let ((imag-tn (complex-double-reg-imag-tn x)))
- (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (str-float real-tn offset nfp))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
(define-move-vop move-complex-double-float-arg :move-arg
(complex-double-reg descriptor-reg) (complex-double-reg))
(inst fsts fp-single-zero-tn 0 csp-tn))))
(macrolet ((frob (name sc zero-sc ptype)
- `(define-vop (,name float-op)
- (:args (x :scs (,sc ,zero-sc))
- (y :scs (,sc ,zero-sc)))
- (:results (r :scs (,sc)))
- (:arg-types ,ptype ,ptype)
- (:result-types ,ptype))))
+ `(define-vop (,name float-op)
+ (:args (x :scs (,sc ,zero-sc))
+ (y :scs (,sc ,zero-sc)))
+ (:results (r :scs (,sc)))
+ (:arg-types ,ptype ,ptype)
+ (:result-types ,ptype))))
(frob single-float-op single-reg fp-single-zero single-float)
(frob double-float-op double-reg fp-double-zero double-float))
(macrolet ((frob (translate op sname scost dname dcost)
- `(progn
- (define-vop (,sname single-float-op)
- (:translate ,translate)
- (:variant ,op)
- (:variant-cost ,scost))
- (define-vop (,dname double-float-op)
- (:translate ,translate)
- (:variant ,op)
- (:variant-cost ,dcost)))))
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,translate)
+ (:variant ,op)
+ (:variant-cost ,scost))
+ (define-vop (,dname double-float-op)
+ (:translate ,translate)
+ (:variant ,op)
+ (:variant-cost ,dcost)))))
(frob + :add +/single-float 2 +/double-float 2)
(frob - :sub -/single-float 2 -/double-float 2)
(frob * :mpy */single-float 4 */double-float 5)
(macrolet ((frob (name translate sc type inst)
- `(define-vop (,name)
- (:args (x :scs (,sc)))
- (:results (y :scs (,sc)))
- (:translate ,translate)
- (:policy :fast-safe)
- (:arg-types ,type)
- (:result-types ,type)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:generator 1
- ,inst
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst fsts fp-single-zero-tn 0 csp-tn))))))
+ `(define-vop (,name)
+ (:args (x :scs (,sc)))
+ (:results (y :scs (,sc)))
+ (:translate ,translate)
+ (:policy :fast-safe)
+ (:arg-types ,type)
+ (:result-types ,type)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator 1
+ ,inst
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst fsts fp-single-zero-tn 0 csp-tn))))))
(frob abs/single-float abs single-reg single-float
(inst funop :abs x y))
(frob abs/double-float abs double-reg double-float
(inst b target :nullify t)))
(macrolet ((frob (name sc zero-sc ptype)
- `(define-vop (,name float-compare)
- (:args (x :scs (,sc ,zero-sc))
- (y :scs (,sc ,zero-sc)))
- (:arg-types ,ptype ,ptype))))
+ `(define-vop (,name float-compare)
+ (:args (x :scs (,sc ,zero-sc))
+ (y :scs (,sc ,zero-sc)))
+ (:arg-types ,ptype ,ptype))))
(frob single-float-compare single-reg fp-single-zero single-float)
(frob double-float-compare double-reg fp-double-zero double-float))
(macrolet ((frob (translate condition complement sname dname)
- `(progn
- (define-vop (,sname single-float-compare)
- (:translate ,translate)
- (:variant ,condition ,complement))
- (define-vop (,dname double-float-compare)
- (:translate ,translate)
- (:variant ,condition ,complement)))))
+ `(progn
+ (define-vop (,sname single-float-compare)
+ (:translate ,translate)
+ (:variant ,condition ,complement))
+ (define-vop (,dname double-float-compare)
+ (:translate ,translate)
+ (:variant ,condition ,complement)))))
(frob < #b01001 #b10101 </single-float </double-float)
(frob > #b10001 #b01101 >/single-float >/double-float)
(frob = #b00101 #b11001 eql/single-float eql/double-float))
;;;; Conversion:
(macrolet ((frob (name translate from-sc from-type to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (,from-sc)))
- (: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)
- (:node-var node)
- (:generator 2
- (inst fcnvff x y)
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst fsts fp-single-zero-tn 0 csp-tn))))))
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc)))
+ (: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)
+ (:node-var node)
+ (:generator 2
+ (inst fcnvff x y)
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst fsts fp-single-zero-tn 0 csp-tn))))))
(frob %single-float/double-float %single-float
double-reg double-float
single-reg single-float)
double-reg double-float))
(macrolet ((frob (name translate to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (signed-reg)
- :load-if (not (sc-is x signed-stack))
- :target stack-temp))
- (:arg-types signed-num)
- (:results (y :scs (,to-sc)))
- (:result-types ,to-type)
- (:policy :fast-safe)
- (:note "inline float coercion")
- (:translate ,translate)
- (:vop-var vop)
- (:save-p :compute-only)
- (:node-var node)
- (:temporary (:scs (signed-stack) :from (:argument 0))
- stack-temp)
- (:temporary (:scs (single-reg) :to (:result 0) :target y)
- fp-temp)
- (:temporary (:scs (any-reg) :from (:argument 0)
- :to (:result 0)) index)
- (:generator 5
- (let* ((nfp (current-nfp-tn vop))
- (stack-tn
- (sc-case x
- (signed-stack
- x)
- (signed-reg
- (storew x nfp (tn-offset stack-temp))
- stack-temp)))
- (offset (* (tn-offset stack-tn) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst flds offset nfp fp-temp))
- (t
- (inst ldo offset zero-tn index)
- (inst fldx index nfp fp-temp)))
- (inst fcnvxf fp-temp y)
- (when (policy node (or (= debug 3) (> safety speed)))
- (note-next-instruction vop :internal-error)
- (inst fsts fp-single-zero-tn 0 csp-tn)))))))
+ `(define-vop (,name)
+ (:args (x :scs (signed-reg)
+ :load-if (not (sc-is x signed-stack))
+ :target stack-temp))
+ (:arg-types signed-num)
+ (:results (y :scs (,to-sc)))
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:temporary (:scs (signed-stack) :from (:argument 0))
+ stack-temp)
+ (:temporary (:scs (single-reg) :to (:result 0) :target y)
+ fp-temp)
+ (:temporary (:scs (any-reg) :from (:argument 0)
+ :to (:result 0)) index)
+ (:generator 5
+ (let* ((nfp (current-nfp-tn vop))
+ (stack-tn
+ (sc-case x
+ (signed-stack
+ x)
+ (signed-reg
+ (storew x nfp (tn-offset stack-temp))
+ stack-temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst flds offset nfp fp-temp))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp fp-temp)))
+ (inst fcnvxf fp-temp y)
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst fsts fp-single-zero-tn 0 csp-tn)))))))
(frob %single-float/signed %single-float
single-reg single-float)
(frob %double-float/signed %double-float
(macrolet ((frob (trans from-sc from-type inst note)
- `(define-vop (,(symbolicate trans "/" from-type))
- (:args (x :scs (,from-sc)
- :target fp-temp))
- (:results (y :scs (signed-reg)
- :load-if (not (sc-is y signed-stack))))
- (:arg-types ,from-type)
- (:result-types signed-num)
- (:translate ,trans)
- (:policy :fast-safe)
- (:note ,note)
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
- (:temporary (:scs (signed-stack) :to (:result 0) :target y)
- stack-temp)
- (:temporary (:scs (any-reg) :from (:argument 0)
- :to (:result 0)) index)
- (:generator 3
- (let* ((nfp (current-nfp-tn vop))
- (stack-tn
- (sc-case y
- (signed-stack y)
- (signed-reg stack-temp)))
- (offset (* (tn-offset stack-tn) n-word-bytes)))
- (inst ,inst x fp-temp)
- (cond ((< offset (ash 1 4))
- (note-next-instruction vop :internal-error)
- (inst fsts fp-temp offset nfp))
- (t
- (inst ldo offset zero-tn index)
- (note-next-instruction vop :internal-error)
- (inst fstx fp-temp index nfp)))
- (unless (eq y stack-tn)
- (loadw y nfp (tn-offset stack-tn))))))))
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc)
+ :target fp-temp))
+ (:results (y :scs (signed-reg)
+ :load-if (not (sc-is y signed-stack))))
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note ,note)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
+ (:temporary (:scs (signed-stack) :to (:result 0) :target y)
+ stack-temp)
+ (:temporary (:scs (any-reg) :from (:argument 0)
+ :to (:result 0)) index)
+ (:generator 3
+ (let* ((nfp (current-nfp-tn vop))
+ (stack-tn
+ (sc-case y
+ (signed-stack y)
+ (signed-reg stack-temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (inst ,inst x fp-temp)
+ (cond ((< offset (ash 1 4))
+ (note-next-instruction vop :internal-error)
+ (inst fsts fp-temp offset nfp))
+ (t
+ (inst ldo offset zero-tn index)
+ (note-next-instruction vop :internal-error)
+ (inst fstx fp-temp index nfp)))
+ (unless (eq y stack-tn)
+ (loadw y nfp (tn-offset stack-tn))))))))
(frob %unary-round single-reg single-float fcnvfx "inline float round")
(frob %unary-round double-reg double-float fcnvfx "inline float round")
(frob %unary-truncate single-reg single-float fcnvfxt
(define-vop (make-single-float)
(:args (bits :scs (signed-reg)
- :load-if (or (not (sc-is bits signed-stack))
- (sc-is res single-stack))
- :target res))
+ :load-if (or (not (sc-is bits signed-stack))
+ (sc-is res single-stack))
+ :target res))
(:results (res :scs (single-reg)
- :load-if (not (sc-is bits single-stack))))
+ :load-if (not (sc-is bits single-stack))))
(:arg-types signed-num)
(:result-types single-float)
(:translate make-single-float)
(:generator 2
(let ((nfp (current-nfp-tn vop)))
(sc-case bits
- (signed-reg
- (sc-case res
- (single-reg
- (let ((offset (* (tn-offset temp) n-word-bytes)))
- (inst stw bits offset nfp)
- (cond ((< offset (ash 1 4))
- (inst flds offset nfp res))
- (t
- (inst ldo offset zero-tn index)
- (inst fldx index nfp res)))))
- (single-stack
- (inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
- (signed-stack
- (sc-case res
- (single-reg
- (let ((offset (* (tn-offset bits) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst flds offset nfp res))
- (t
- (inst ldo offset zero-tn index)
- (inst fldx index nfp res)))))))))))
+ (signed-reg
+ (sc-case res
+ (single-reg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (inst stw bits offset nfp)
+ (cond ((< offset (ash 1 4))
+ (inst flds offset nfp res))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp res)))))
+ (single-stack
+ (inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
+ (signed-stack
+ (sc-case res
+ (single-reg
+ (let ((offset (* (tn-offset bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst flds offset nfp res))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp res)))))))))))
(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)
- :load-if (not (sc-is res double-stack))))
+ :load-if (not (sc-is res double-stack))))
(:arg-types signed-num unsigned-num)
(:result-types double-float)
(:translate make-double-float)
(:vop-var vop)
(:generator 2
(let* ((nfp (current-nfp-tn vop))
- (stack-tn (sc-case res
- (double-stack res)
- (double-reg temp)))
- (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (stack-tn (sc-case res
+ (double-stack res)
+ (double-reg temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
(inst stw hi-bits offset nfp)
(inst stw lo-bits (+ offset n-word-bytes) nfp)
(cond ((eq stack-tn res))
- ((< offset (ash 1 4))
- (inst flds offset nfp res))
- (t
- (inst ldo offset zero-tn index)
- (inst fldx index nfp res))))))
+ ((< offset (ash 1 4))
+ (inst flds offset nfp res))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp res))))))
(define-vop (single-float-bits)
(:args (float :scs (single-reg)
- :load-if (not (sc-is float single-stack))))
+ :load-if (not (sc-is float single-stack))))
(:results (bits :scs (signed-reg)
- :load-if (or (not (sc-is bits signed-stack))
- (sc-is float single-stack))))
+ :load-if (or (not (sc-is bits signed-stack))
+ (sc-is float single-stack))))
(:arg-types single-float)
(:result-types signed-num)
(:translate single-float-bits)
(:generator 2
(let ((nfp (current-nfp-tn vop)))
(sc-case float
- (single-reg
- (sc-case bits
- (signed-reg
- (let ((offset (* (tn-offset temp) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp)))
- (inst ldw offset nfp bits)))
- (signed-stack
- (let ((offset (* (tn-offset bits) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp)))))))
- (single-stack
- (sc-case bits
- (signed-reg
- (inst ldw (* (tn-offset float) n-word-bytes) nfp bits))))))))
+ (single-reg
+ (sc-case bits
+ (signed-reg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp)))
+ (inst ldw offset nfp bits)))
+ (signed-stack
+ (let ((offset (* (tn-offset bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp)))))))
+ (single-stack
+ (sc-case bits
+ (signed-reg
+ (inst ldw (* (tn-offset float) n-word-bytes) nfp bits))))))))
(define-vop (double-float-high-bits)
(:args (float :scs (double-reg)
- :load-if (not (sc-is float double-stack))))
+ :load-if (not (sc-is float double-stack))))
(:results (hi-bits :scs (signed-reg)
- :load-if (or (not (sc-is hi-bits signed-stack))
- (sc-is float double-stack))))
+ :load-if (or (not (sc-is hi-bits signed-stack))
+ (sc-is float double-stack))))
(:arg-types double-float)
(:result-types signed-num)
(:translate double-float-high-bits)
(:generator 2
(let ((nfp (current-nfp-tn vop)))
(sc-case float
- (double-reg
- (sc-case hi-bits
- (signed-reg
- (let ((offset (* (tn-offset temp) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp :side 0))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp :side 0)))
- (inst ldw offset nfp hi-bits)))
- (signed-stack
- (let ((offset (* (tn-offset hi-bits) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp :side 0))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp :side 0)))))))
- (double-stack
- (sc-case hi-bits
- (signed-reg
- (let ((offset (* (tn-offset float) n-word-bytes)))
- (inst ldw offset nfp hi-bits)))))))))
+ (double-reg
+ (sc-case hi-bits
+ (signed-reg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp :side 0))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp :side 0)))
+ (inst ldw offset nfp hi-bits)))
+ (signed-stack
+ (let ((offset (* (tn-offset hi-bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp :side 0))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp :side 0)))))))
+ (double-stack
+ (sc-case hi-bits
+ (signed-reg
+ (let ((offset (* (tn-offset float) n-word-bytes)))
+ (inst ldw offset nfp hi-bits)))))))))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg)
- :load-if (not (sc-is float double-stack))))
+ :load-if (not (sc-is float double-stack))))
(:results (lo-bits :scs (unsigned-reg)
- :load-if (or (not (sc-is lo-bits unsigned-stack))
- (sc-is float double-stack))))
+ :load-if (or (not (sc-is lo-bits unsigned-stack))
+ (sc-is float double-stack))))
(:arg-types double-float)
(:result-types unsigned-num)
(:translate double-float-low-bits)
(:generator 2
(let ((nfp (current-nfp-tn vop)))
(sc-case float
- (double-reg
- (sc-case lo-bits
- (unsigned-reg
- (let ((offset (* (tn-offset temp) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp :side 1))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp :side 1)))
- (inst ldw offset nfp lo-bits)))
- (unsigned-stack
- (let ((offset (* (tn-offset lo-bits) n-word-bytes)))
- (cond ((< offset (ash 1 4))
- (inst fsts float offset nfp :side 1))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx float index nfp :side 1)))))))
- (double-stack
- (sc-case lo-bits
- (unsigned-reg
- (let ((offset (* (1+ (tn-offset float)) n-word-bytes)))
- (inst ldw offset nfp lo-bits)))))))))
+ (double-reg
+ (sc-case lo-bits
+ (unsigned-reg
+ (let ((offset (* (tn-offset temp) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp :side 1))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp :side 1)))
+ (inst ldw offset nfp lo-bits)))
+ (unsigned-stack
+ (let ((offset (* (tn-offset lo-bits) n-word-bytes)))
+ (cond ((< offset (ash 1 4))
+ (inst fsts float offset nfp :side 1))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx float index nfp :side 1)))))))
+ (double-stack
+ (sc-case lo-bits
+ (unsigned-reg
+ (let ((offset (* (1+ (tn-offset float)) n-word-bytes)))
+ (inst ldw offset nfp lo-bits)))))))))
\f
(define-vop (floating-point-modes)
(:results (res :scs (unsigned-reg)
- :load-if (not (sc-is res unsigned-stack))))
+ :load-if (not (sc-is res unsigned-stack))))
(:result-types unsigned-num)
(:translate floating-point-modes)
(:policy :fast-safe)
(:vop-var vop)
(:generator 3
(let* ((nfp (current-nfp-tn vop))
- (stack-tn (sc-case res
- (unsigned-stack res)
- (unsigned-reg temp)))
- (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (stack-tn (sc-case res
+ (unsigned-stack res)
+ (unsigned-reg temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
(cond ((< offset (ash 1 4))
- (inst fsts fp-single-zero-tn offset nfp))
- (t
- (inst ldo offset zero-tn index)
- (inst fstx fp-single-zero-tn index nfp)))
+ (inst fsts fp-single-zero-tn offset nfp))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fstx fp-single-zero-tn index nfp)))
(unless (eq stack-tn res)
- (inst ldw offset nfp res)))))
+ (inst ldw offset nfp res)))))
(define-vop (set-floating-point-modes)
(:args (new :scs (unsigned-reg)
- :load-if (not (sc-is new unsigned-stack))))
+ :load-if (not (sc-is new unsigned-stack))))
(:results (res :scs (unsigned-reg)))
(:arg-types unsigned-num)
(:result-types unsigned-num)
(:vop-var vop)
(:generator 3
(let* ((nfp (current-nfp-tn vop))
- (stack-tn (sc-case new
- (unsigned-stack new)
- (unsigned-reg temp)))
- (offset (* (tn-offset stack-tn) n-word-bytes)))
+ (stack-tn (sc-case new
+ (unsigned-stack new)
+ (unsigned-reg temp)))
+ (offset (* (tn-offset stack-tn) n-word-bytes)))
(unless (eq new stack-tn)
- (inst stw new offset nfp))
+ (inst stw new offset nfp))
(cond ((< offset (ash 1 4))
- (inst flds offset nfp fp-single-zero-tn))
- (t
- (inst ldo offset zero-tn index)
- (inst fldx index nfp fp-single-zero-tn)))
+ (inst flds offset nfp fp-single-zero-tn))
+ (t
+ (inst ldo offset zero-tn index)
+ (inst fldx index nfp fp-single-zero-tn)))
(inst ldw offset nfp res))))
\f
(define-vop (make-complex-single-float)
(:translate complex)
(:args (real :scs (single-reg) :target r)
- (imag :scs (single-reg) :to :save))
+ (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 funop :copy real r-real)))
+ (unless (location= real r-real)
+ (inst funop :copy real r-real)))
(let ((r-imag (complex-single-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst funop :copy imag r-imag))))
+ (unless (location= imag r-imag)
+ (inst funop :copy imag r-imag))))
(complex-single-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (str-float real offset nfp)
- (str-float imag (+ offset n-word-bytes) nfp))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (str-float real offset nfp)
+ (str-float imag (+ offset n-word-bytes) nfp))))))
(define-vop (make-complex-double-float)
(:translate complex)
(:args (real :scs (double-reg) :target r)
- (imag :scs (double-reg) :to :save))
+ (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 funop :copy real r-real)))
+ (unless (location= real r-real)
+ (inst funop :copy real r-real)))
(let ((r-imag (complex-double-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst funop :copy imag r-imag))))
+ (unless (location= imag r-imag)
+ (inst funop :copy imag r-imag))))
(complex-double-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (str-float real offset nfp)
- (str-float imag (+ offset (* 2 n-word-bytes)) nfp))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (str-float real offset nfp)
+ (str-float imag (+ offset (* 2 n-word-bytes)) nfp))))))
(define-vop (complex-single-float-value)
(:args (x :scs (complex-single-reg) :target r
- :load-if (not (sc-is x complex-single-stack))))
+ :load-if (not (sc-is x complex-single-stack))))
(:arg-types complex-single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(sc-case x
(complex-single-reg
(let ((value-tn (ecase slot
- (:real (complex-single-reg-real-tn x))
- (:imag (complex-single-reg-imag-tn x)))))
- (unless (location= value-tn r)
- (inst funop :copy value-tn r))))
+ (:real (complex-single-reg-real-tn x))
+ (:imag (complex-single-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst funop :copy value-tn r))))
(complex-single-stack
(ld-float (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
- n-word-bytes)
- (current-nfp-tn vop) r)))))
+ n-word-bytes)
+ (current-nfp-tn vop) r)))))
(define-vop (realpart/complex-single-float complex-single-float-value)
(:translate realpart)
(define-vop (complex-double-float-value)
(:args (x :scs (complex-double-reg) :target r
- :load-if (not (sc-is x complex-double-stack))))
+ :load-if (not (sc-is x complex-double-stack))))
(:arg-types complex-double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(sc-case x
(complex-double-reg
(let ((value-tn (ecase slot
- (:real (complex-double-reg-real-tn x))
- (:imag (complex-double-reg-imag-tn x)))))
- (unless (location= value-tn r)
- (inst funop :copy value-tn r))))
+ (:real (complex-double-reg-real-tn x))
+ (:imag (complex-double-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst funop :copy value-tn r))))
(complex-double-stack
(ld-float (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
- n-word-bytes)
- (current-nfp-tn vop) r)))))
+ n-word-bytes)
+ (current-nfp-tn vop) r)))))
(define-vop (realpart/complex-double-float complex-double-float-value)
(:translate realpart)
(declare (type compare-condition cond))
(if cond
(let ((result (or (position cond compare-conditions :test #'eq)
- (error "Bogus Compare/Subtract condition: ~S" cond))))
- (values (ldb (byte 3 0) result)
- (logbitp 3 result)))
+ (error "Bogus Compare/Subtract condition: ~S" cond))))
+ (values (ldb (byte 3 0) result)
+ (logbitp 3 result)))
(values 0 nil)))
(defconstant-eqx add-conditions
(declare (type add-condition cond))
(if cond
(let ((result (or (position cond add-conditions :test #'eq)
- (error "Bogus Add condition: ~S" cond))))
- (values (ldb (byte 3 0) result)
- (logbitp 3 result)))
+ (error "Bogus Add condition: ~S" cond))))
+ (values (ldb (byte 3 0) result)
+ (logbitp 3 result)))
(values 0 nil)))
(defconstant-eqx logical-conditions
(declare (type logical-condition cond))
(if cond
(let ((result (or (position cond logical-conditions :test #'eq)
- (error "Bogus Logical condition: ~S" cond))))
- (values (ldb (byte 3 0) result)
- (logbitp 3 result)))
+ (error "Bogus Logical condition: ~S" cond))))
+ (values (ldb (byte 3 0) result)
+ (logbitp 3 result)))
(values 0 nil)))
(defconstant-eqx unit-conditions
(declare (type unit-condition cond))
(if cond
(let ((result (or (position cond unit-conditions :test #'eq)
- (error "Bogus Unit condition: ~S" cond))))
- (values (ldb (byte 3 0) result)
- (logbitp 3 result)))
+ (error "Bogus Unit condition: ~S" cond))))
+ (values (ldb (byte 3 0) result)
+ (logbitp 3 result)))
(values 0 nil)))
(defconstant-eqx extract/deposit-conditions
(declare (type extract/deposit-condition cond))
(if cond
(or (position cond extract/deposit-conditions :test #'eq)
- (error "Bogus Extract/Deposit condition: ~S" cond))
+ (error "Bogus Extract/Deposit condition: ~S" cond))
0))
(defparameter reg-symbols
(map 'vector
#'(lambda (name)
- (cond ((null name) nil)
- (t (make-symbol (concatenate 'string "$" name)))))
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "$" name)))))
*register-names*))
(sb!disassem:define-arg-type reg
:printer #'(lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'registers
- regname
- dstate))))
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'registers
+ regname
+ dstate))))
(defparameter float-reg-symbols
#.(coerce
(sb!disassem:define-arg-type fp-fmt-0c
:printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (ecase value
- (0 (format stream "~A" '\,SGL))
- (1 (format stream "~A" '\,DBL))
- (3 (format stream "~A" '\,QUAD)))))
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (ecase value
+ (0 (format stream "~A" '\,SGL))
+ (1 (format stream "~A" '\,DBL))
+ (3 (format stream "~A" '\,QUAD)))))
(defun low-sign-extend (x n)
(let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
(if (logbitp 0 x)
- (logior (ash -1 (1- n)) normal)
- normal)))
+ (logior (ash -1 (1- n)) normal)
+ normal)))
(defun sign-extend (x n)
(if (logbitp (1- n) x)
(defun assemble-bits (x list)
(let ((result 0)
- (offset 0))
+ (offset 0))
(dolist (e (reverse list))
(setf result (logior result (ash (ldb e x) offset)))
(incf offset (byte-size e)))
(defmacro define-imx-decode (name bits)
`(sb!disassem:define-arg-type ,name
:printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" (low-sign-extend value ,bits)))))
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (low-sign-extend value ,bits)))))
(define-imx-decode im5 5)
(define-imx-decode im11 11)
(sb!disassem:define-arg-type im3
:printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" (assemble-bits value `(,(byte 1 0)
- ,(byte 2 1))))))
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (assemble-bits value `(,(byte 1 0)
+ ,(byte 2 1))))))
(sb!disassem:define-arg-type im21
:printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S"
- (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
- ,(byte 2 14) ,(byte 5 16)
- ,(byte 2 12))))))
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S"
+ (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
+ ,(byte 2 14) ,(byte 5 16)
+ ,(byte 2 12))))))
(sb!disassem:define-arg-type cp
:printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" (- 31 value))))
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (- 31 value))))
(sb!disassem:define-arg-type clen
:printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" (- 32 value))))
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (- 32 value))))
(sb!disassem:define-arg-type compare-condition
:printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
- \,> \,>>= \,>> \,NSV \,EV))
+ \,> \,>>= \,>> \,NSV \,EV))
(sb!disassem:define-arg-type compare-condition-false
:printer #(\,TR \,<> \,>= \,> \,>>= \,>> \,NSV \,EV
- "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))
+ "" \,= \,< \,<= \,<< \,<<= \,SV \,OD))
(sb!disassem:define-arg-type add-condition
:printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
- \,VNZ \,NSV \,EV))
+ \,VNZ \,NSV \,EV))
(sb!disassem:define-arg-type add-condition-false
:printer #(\,TR \,<> \,>= \,> \,UV \,VNZ \,NSV \,EV
- "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))
+ "" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD))
(sb!disassem:define-arg-type logical-condition
:printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
(sb!disassem:define-arg-type unit-condition
:printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
- \,NBC \,NHC))
+ \,NBC \,NHC))
(sb!disassem:define-arg-type extract/deposit-condition
:printer #("" \,= \,< \,OD \,TR \,<> \,>= \,EV))
(sb!disassem:define-arg-type fcmp-cond
:printer #(\FALSE? \FALSE \? \!<=> \= \=T \?= \!<> \!?>= \< \?<
- \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
- \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
+ \!>= \!?> \<= \?<= \!> \!?<= \> \?>\ \!<= \!?< \>=
+ \?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
(sb!disassem:define-arg-type integer
:printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" value)))
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" value)))
(sb!disassem:define-arg-type space
:printer #("" |1,| |2,| |3,|))
(im14 :field (byte 14 0) :type 'im14))
(defconstant-eqx cmplt-index-print '((:cond ((u :constant 1) '\,S))
- (:cond ((m :constant 1) '\,M)))
+ (:cond ((m :constant 1) '\,M)))
#'equalp)
(defconstant-eqx cmplt-disp-print '((:cond ((m :constant 1)
- (:cond ((s :constant 0) '\,MA)
- (t '\,MB)))))
+ (:cond ((s :constant 0) '\,MA)
+ (t '\,MB)))))
#'equalp)
(defconstant-eqx cmplt-store-print '((:cond ((s :constant 0) '\,B)
- (t '\,E))
- (:cond ((m :constant 1) '\,M)))
+ (t '\,E))
+ (:cond ((m :constant 1) '\,M)))
#'equalp)
(sb!disassem:define-instruction-format
(w :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
:use-label
#'(lambda (value dstate)
- (declare (type sb!disassem:disassem-state dstate) (list value))
- (let ((x (logior (ash (first value) 12) (ash (second value) 1)
- (third value))))
- (+ (ash (sign-extend
- (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
- ,(byte 10 2))) 17) 2)
- (sb!disassem:dstate-cur-addr dstate) 8))))
+ (declare (type sb!disassem:disassem-state dstate) (list value))
+ (let ((x (logior (ash (first value) 12) (ash (second value) 1)
+ (third value))))
+ (+ (ash (sign-extend
+ (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
+ ,(byte 10 2))) 17) 2)
+ (sb!disassem:dstate-cur-addr dstate) 8))))
(op2 :field (byte 3 13))
(n :field (byte 1 1) :type 'nullify))
(w :fields `(,(byte 11 2) ,(byte 1 0))
:use-label
#'(lambda (value dstate)
- (declare (type sb!disassem:disassem-state dstate) (list value))
- (let ((x (logior (ash (first value) 1) (second value))))
- (+ (ash (sign-extend
- (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
- 12) 2)
- (sb!disassem:dstate-cur-addr dstate) 8))))
+ (declare (type sb!disassem:disassem-state dstate) (list value))
+ (let ((x (logior (ash (first value) 1) (second value))))
+ (+ (ash (sign-extend
+ (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
+ 12) 2)
+ (sb!disassem:dstate-cur-addr dstate) 8))))
(c :field (byte 3 13))
(n :field (byte 1 1) :type 'nullify))
(defun im14-encoding (segment disp)
(declare (type (or fixup (signed-byte 14))))
(cond ((fixup-p disp)
- (note-fixup segment :load disp)
- (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
- 0)
- (t
- (dpb (ldb (byte 13 0) disp)
- (byte 13 1)
- (ldb (byte 1 13) disp)))))
+ (note-fixup segment :load disp)
+ (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ 0)
+ (t
+ (dpb (ldb (byte 13 0) disp)
+ (byte 13 1)
+ (ldb (byte 1 13) disp)))))
(macrolet ((define-load-inst (name opcode)
- `(define-instruction ,name (segment disp base reg)
- (:declare (type tn reg base)
- (type (or fixup (signed-byte 14)) disp))
- (:printer load/store ((op ,opcode) (s 0))
- '(:name :tab im14 "(" s b ")," t/r))
- (:emitter
- (emit-load/store segment ,opcode
- (reg-tn-encoding base) (reg-tn-encoding reg) 0
- (im14-encoding segment disp)))))
- (define-store-inst (name opcode)
- `(define-instruction ,name (segment reg disp base)
- (:declare (type tn reg base)
- (type (or fixup (signed-byte 14)) disp))
- (:printer load/store ((op ,opcode) (s 0))
- '(:name :tab t/r "," im14 "(" s b ")"))
- (:emitter
- (emit-load/store segment ,opcode
- (reg-tn-encoding base) (reg-tn-encoding reg) 0
- (im14-encoding segment disp))))))
+ `(define-instruction ,name (segment disp base reg)
+ (:declare (type tn reg base)
+ (type (or fixup (signed-byte 14)) disp))
+ (:printer load/store ((op ,opcode) (s 0))
+ '(:name :tab im14 "(" s b ")," t/r))
+ (:emitter
+ (emit-load/store segment ,opcode
+ (reg-tn-encoding base) (reg-tn-encoding reg) 0
+ (im14-encoding segment disp)))))
+ (define-store-inst (name opcode)
+ `(define-instruction ,name (segment reg disp base)
+ (:declare (type tn reg base)
+ (type (or fixup (signed-byte 14)) disp))
+ (:printer load/store ((op ,opcode) (s 0))
+ '(:name :tab t/r "," im14 "(" s b ")"))
+ (:emitter
+ (emit-load/store segment ,opcode
+ (reg-tn-encoding base) (reg-tn-encoding reg) 0
+ (im14-encoding segment disp))))))
(define-load-inst ldw #x12)
(define-load-inst ldh #x11)
(define-load-inst ldb #x10)
(byte 3 10) (byte 4 6) (byte 1 5) (byte 5 0))
(macrolet ((define-load-indexed-inst (name opcode)
- `(define-instruction ,name (segment index base reg &key modify scale)
- (:declare (type tn reg base index)
- (type (member t nil) modify scale))
- (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
- (op2 0))
- `(:name ,@cmplt-index-print :tab x/im5/r
- "(" s b ")" t/im5))
- (:emitter
- (emit-extended-load/store
- segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
- 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
- (reg-tn-encoding reg))))))
+ `(define-instruction ,name (segment index base reg &key modify scale)
+ (:declare (type tn reg base index)
+ (type (member t nil) modify scale))
+ (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
+ (op2 0))
+ `(:name ,@cmplt-index-print :tab x/im5/r
+ "(" s b ")" t/im5))
+ (:emitter
+ (emit-extended-load/store
+ segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
+ 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
+ (reg-tn-encoding reg))))))
(define-load-indexed-inst ldwx 2)
(define-load-indexed-inst ldhx 1)
(define-load-indexed-inst ldbx 0)
(defun short-disp-encoding (segment disp)
(declare (type (or fixup (signed-byte 5)) disp))
(cond ((fixup-p disp)
- (note-fixup segment :load-short disp)
- (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
- 0)
- (t
- (dpb (ldb (byte 4 0) disp)
- (byte 4 1)
- (ldb (byte 1 4) disp)))))
+ (note-fixup segment :load-short disp)
+ (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ 0)
+ (t
+ (dpb (ldb (byte 4 0) disp)
+ (byte 4 1)
+ (ldb (byte 1 4) disp)))))
(macrolet ((define-load-short-inst (name opcode)
- `(define-instruction ,name (segment base disp reg &key modify)
- (:declare (type tn base reg)
- (type (or fixup (signed-byte 5)) disp)
- (type (member :before :after nil) modify))
- (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
- (op2 4))
- `(:name ,@cmplt-disp-print :tab x/im5/r
- "(" s b ")" t/im5))
- (:emitter
- (multiple-value-bind
- (m a)
- (ecase modify
- ((nil) (values 0 0))
- (:after (values 1 0))
- (:before (values 1 1)))
- (emit-extended-load/store segment #x03 (reg-tn-encoding base)
- (short-disp-encoding segment disp)
- 0 a 4 ,opcode m
- (reg-tn-encoding reg))))))
- (define-store-short-inst (name opcode)
- `(define-instruction ,name (segment reg base disp &key modify)
- (:declare (type tn reg base)
- (type (or fixup (signed-byte 5)) disp)
- (type (member :before :after nil) modify))
- (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
- (op2 4))
- `(:name ,@cmplt-disp-print :tab x/im5/r
- "," t/im5 "(" s b ")"))
- (:emitter
- (multiple-value-bind
- (m a)
- (ecase modify
- ((nil) (values 0 0))
- (:after (values 1 0))
- (:before (values 1 1)))
- (emit-extended-load/store segment #x03 (reg-tn-encoding base)
- (short-disp-encoding segment disp)
- 0 a 4 ,opcode m
- (reg-tn-encoding reg)))))))
+ `(define-instruction ,name (segment base disp reg &key modify)
+ (:declare (type tn base reg)
+ (type (or fixup (signed-byte 5)) disp)
+ (type (member :before :after nil) modify))
+ (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
+ (op2 4))
+ `(:name ,@cmplt-disp-print :tab x/im5/r
+ "(" s b ")" t/im5))
+ (:emitter
+ (multiple-value-bind
+ (m a)
+ (ecase modify
+ ((nil) (values 0 0))
+ (:after (values 1 0))
+ (:before (values 1 1)))
+ (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+ (short-disp-encoding segment disp)
+ 0 a 4 ,opcode m
+ (reg-tn-encoding reg))))))
+ (define-store-short-inst (name opcode)
+ `(define-instruction ,name (segment reg base disp &key modify)
+ (:declare (type tn reg base)
+ (type (or fixup (signed-byte 5)) disp)
+ (type (member :before :after nil) modify))
+ (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
+ (op2 4))
+ `(:name ,@cmplt-disp-print :tab x/im5/r
+ "," t/im5 "(" s b ")"))
+ (:emitter
+ (multiple-value-bind
+ (m a)
+ (ecase modify
+ ((nil) (values 0 0))
+ (:after (values 1 0))
+ (:before (values 1 1)))
+ (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+ (short-disp-encoding segment disp)
+ 0 a 4 ,opcode m
+ (reg-tn-encoding reg)))))))
(define-load-short-inst ldws 2)
(define-load-short-inst ldhs 1)
(define-load-short-inst ldbs 0)
(define-load-short-inst ldcws 7)
-
+
(define-store-short-inst stws 10)
(define-store-short-inst sths 9)
(define-store-short-inst stbs 8))
(define-instruction stbys (segment reg base disp where &key modify)
(:declare (type tn reg base)
- (type (signed-byte 5) disp)
- (type (member :begin :end) where)
- (type (member t nil) modify))
+ (type (signed-byte 5) disp)
+ (type (member :begin :end) where)
+ (type (member t nil) modify))
(:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
- `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
+ `(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
(:emitter
(emit-extended-load/store segment #x03 (reg-tn-encoding base)
- (reg-tn-encoding reg) 0
- (ecase where (:begin 0) (:end 1))
- 4 #xC (if modify 1 0)
- (short-disp-encoding segment disp))))
+ (reg-tn-encoding reg) 0
+ (ecase where (:begin 0) (:end 1))
+ 4 #xC (if modify 1 0)
+ (short-disp-encoding segment disp))))
\f
;;;; Immediate Instructions.
(defun immed-21-encoding (segment value)
(declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value))
(cond ((fixup-p value)
- (note-fixup segment :hi value)
- (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
- 0)
- (t
- (logior (ash (ldb (byte 5 2) value) 16)
- (ash (ldb (byte 2 7) value) 14)
- (ash (ldb (byte 2 0) value) 12)
- (ash (ldb (byte 11 9) value) 1)
- (ldb (byte 1 20) value)))))
+ (note-fixup segment :hi value)
+ (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
+ 0)
+ (t
+ (logior (ash (ldb (byte 5 2) value) 16)
+ (ash (ldb (byte 2 7) value) 14)
+ (ash (ldb (byte 2 0) value) 12)
+ (ash (ldb (byte 11 9) value) 1)
+ (ldb (byte 1 20) value)))))
(define-instruction ldil (segment value reg)
(:declare (type tn reg)
- (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+ (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
(:printer ldil ((op #x08)))
(:emitter
(emit-ldil segment #x08 (reg-tn-encoding reg)
- (immed-21-encoding segment value))))
+ (immed-21-encoding segment value))))
(define-instruction addil (segment value reg)
(:declare (type tn reg)
- (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+ (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
(:printer ldil ((op #x0A)))
(:emitter
(emit-ldil segment #x0A (reg-tn-encoding reg)
- (immed-21-encoding segment value))))
+ (immed-21-encoding segment value))))
\f
;;;; Branch instructions.
(defun label-relative-displacement (label posn &optional delta-if-after)
(declare (type label label) (type index posn))
(ash (- (if delta-if-after
- (label-position label posn delta-if-after)
- (label-position label))
- (+ posn 8)) -2))
+ (label-position label posn delta-if-after)
+ (label-position label))
+ (+ posn 8)) -2))
(defun decompose-branch-disp (segment disp)
(declare (type (or fixup (signed-byte 17)) disp))
(cond ((fixup-p disp)
- (note-fixup segment :branch disp)
- (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
- (values 0 0 0))
- (t
- (values (ldb (byte 5 11) disp)
- (dpb (ldb (byte 10 0) disp)
- (byte 10 1)
- (ldb (byte 1 10) disp))
- (ldb (byte 1 16) disp)))))
+ (note-fixup segment :branch disp)
+ (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ (values 0 0 0))
+ (t
+ (values (ldb (byte 5 11) disp)
+ (dpb (ldb (byte 10 0) disp)
+ (byte 10 1)
+ (ldb (byte 1 10) disp))
+ (ldb (byte 1 16) disp)))))
(defun emit-relative-branch (segment opcode link sub-opcode target nullify)
(declare (type (unsigned-byte 6) opcode)
- (type (unsigned-byte 5) link)
- (type (unsigned-byte 1) sub-opcode)
- (type label target)
- (type (member t nil) nullify))
+ (type (unsigned-byte 5) link)
+ (type (unsigned-byte 1) sub-opcode)
+ (type label target)
+ (type (member t nil) nullify))
(emit-back-patch segment 4
#'(lambda (segment posn)
- (let ((disp (label-relative-displacement target posn)))
- (aver (<= (- (ash 1 16)) disp (1- (ash 1 16))))
- (multiple-value-bind
- (w1 w2 w)
- (decompose-branch-disp segment disp)
- (emit-branch segment opcode link w1 sub-opcode w2
- (if nullify 1 0) w))))))
+ (let ((disp (label-relative-displacement target posn)))
+ (aver (<= (- (ash 1 16)) disp (1- (ash 1 16))))
+ (multiple-value-bind
+ (w1 w2 w)
+ (decompose-branch-disp segment disp)
+ (emit-branch segment opcode link w1 sub-opcode w2
+ (if nullify 1 0) w))))))
(define-instruction b (segment target &key nullify)
(:declare (type label target) (type (member t nil) nullify))
(define-instruction bv (segment base &key nullify offset)
(:declare (type tn base)
- (type (member t nil) nullify)
- (type (or tn null) offset))
+ (type (member t nil) nullify)
+ (type (or tn null) offset))
(:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
(:emitter
(emit-branch segment #x3A (reg-tn-encoding base)
- (if offset (reg-tn-encoding offset) 0)
- 6 0 (if nullify 1 0) 0)))
+ (if offset (reg-tn-encoding offset) 0)
+ 6 0 (if nullify 1 0) 0)))
(define-instruction be (segment disp space base &key nullify)
(:declare (type (or fixup (signed-byte 17)) disp)
- (type tn base)
- (type (unsigned-byte 3) space)
- (type (member t nil) nullify))
+ (type tn base)
+ (type (unsigned-byte 3) space)
+ (type (member t nil) nullify))
(:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
- '(:name n :tab w "(" op2 "," t ")"))
+ '(:name n :tab w "(" op2 "," t ")"))
(:emitter
(multiple-value-bind
(w1 w2 w)
(decompose-branch-disp segment disp)
(emit-branch segment #x38 (reg-tn-encoding base) w1
- (space-encoding space) w2 (if nullify 1 0) w))))
+ (space-encoding space) w2 (if nullify 1 0) w))))
(define-instruction ble (segment disp space base &key nullify)
(:declare (type (or fixup (signed-byte 17)) disp)
- (type tn base)
- (type (unsigned-byte 3) space)
- (type (member t nil) nullify))
+ (type tn base)
+ (type (unsigned-byte 3) space)
+ (type (member t nil) nullify))
(:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
- '(:name n :tab w "(" op2 "," t ")"))
+ '(:name n :tab w "(" op2 "," t ")"))
(:emitter
(multiple-value-bind
(w1 w2 w)
(decompose-branch-disp segment disp)
(emit-branch segment #x39 (reg-tn-encoding base) w1
- (space-encoding space) w2 (if nullify 1 0) w))))
+ (space-encoding space) w2 (if nullify 1 0) w))))
(defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
(emit-back-patch segment 4
#'(lambda (segment posn)
- (let ((disp (label-relative-displacement target posn)))
- (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
- (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
- (ldb (byte 1 10) disp)))
- (w (ldb (byte 1 11) disp)))
- (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
+ (let ((disp (label-relative-displacement target posn)))
+ (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
+ (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
+ (ldb (byte 1 10) disp)))
+ (w (ldb (byte 1 11) disp)))
+ (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
(defun im5-encoding (value)
(declare (type (signed-byte 5) value)
- #+nil (values (unsigned-byte 5)))
+ #+nil (values (unsigned-byte 5)))
(dpb (ldb (byte 4 0) value)
(byte 4 1)
(ldb (byte 1 4) value)))
(macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
- (let* ((conditional (symbolicate cond-kind "-CONDITION"))
- (false-conditional (symbolicate conditional "-FALSE")))
- `(progn
- (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
- (:declare (type ,conditional cond)
- (type tn r1 r2)
- (type label target)
- (type (member t nil) nullify))
- (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
- '(:name c n :tab r1 "," r2 "," w))
- ,@(unless (= r-opcode #x32)
- `((:printer branch12 ((op1 ,(+ 2 r-opcode))
- (c nil :type ',false-conditional))
- '(:name c n :tab r1 "," r2 "," w))))
- (:emitter
- (multiple-value-bind
- (cond-encoding false)
- (,conditional cond)
- (emit-conditional-branch
- segment (if false ,(+ r-opcode 2) ,r-opcode)
- (reg-tn-encoding r2) (reg-tn-encoding r1)
- cond-encoding target nullify))))
- (define-instruction ,i-name (segment cond imm reg target &key nullify)
- (:declare (type ,conditional cond)
- (type (signed-byte 5) imm)
- (type tn reg)
- (type (member t nil) nullify))
- (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
- (c nil :type ',conditional))
- '(:name c n :tab r1 "," r2 "," w))
- ,@(unless (= r-opcode #x32)
- `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
- (c nil :type ',false-conditional))
- '(:name c n :tab r1 "," r2 "," w))))
- (:emitter
- (multiple-value-bind
- (cond-encoding false)
- (,conditional cond)
- (emit-conditional-branch
- segment (if false (+ ,i-opcode 2) ,i-opcode)
- (reg-tn-encoding reg) (im5-encoding imm)
- cond-encoding target nullify))))))))
+ (let* ((conditional (symbolicate cond-kind "-CONDITION"))
+ (false-conditional (symbolicate conditional "-FALSE")))
+ `(progn
+ (define-instruction ,r-name (segment cond r1 r2 target &key nullify)
+ (:declare (type ,conditional cond)
+ (type tn r1 r2)
+ (type label target)
+ (type (member t nil) nullify))
+ (:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
+ '(:name c n :tab r1 "," r2 "," w))
+ ,@(unless (= r-opcode #x32)
+ `((:printer branch12 ((op1 ,(+ 2 r-opcode))
+ (c nil :type ',false-conditional))
+ '(:name c n :tab r1 "," r2 "," w))))
+ (:emitter
+ (multiple-value-bind
+ (cond-encoding false)
+ (,conditional cond)
+ (emit-conditional-branch
+ segment (if false ,(+ r-opcode 2) ,r-opcode)
+ (reg-tn-encoding r2) (reg-tn-encoding r1)
+ cond-encoding target nullify))))
+ (define-instruction ,i-name (segment cond imm reg target &key nullify)
+ (:declare (type ,conditional cond)
+ (type (signed-byte 5) imm)
+ (type tn reg)
+ (type (member t nil) nullify))
+ (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
+ (c nil :type ',conditional))
+ '(:name c n :tab r1 "," r2 "," w))
+ ,@(unless (= r-opcode #x32)
+ `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
+ (c nil :type ',false-conditional))
+ '(:name c n :tab r1 "," r2 "," w))))
+ (:emitter
+ (multiple-value-bind
+ (cond-encoding false)
+ (,conditional cond)
+ (emit-conditional-branch
+ segment (if false (+ ,i-opcode 2) ,i-opcode)
+ (reg-tn-encoding reg) (im5-encoding imm)
+ cond-encoding target nullify))))))))
(define-branch-inst movb #x32 movib #x33 extract/deposit)
(define-branch-inst comb #x20 comib #x21 compare)
(define-branch-inst addb #x28 addib #x29 add))
(define-instruction bb (segment cond reg posn target &key nullify)
(:declare (type (member t nil) cond nullify)
- (type tn reg)
- (type (or (member :variable) (unsigned-byte 5)) posn))
+ (type tn reg)
+ (type (or (member :variable) (unsigned-byte 5)) posn))
(:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
- '('BVB c n :tab r1 "," w))
+ '('BVB c n :tab r1 "," w))
(:emitter
(multiple-value-bind
(opcode posn-encoding)
(if (eq posn :variable)
- (values #x30 0)
- (values #x31 posn))
+ (values #x30 0)
+ (values #x31 posn))
(emit-conditional-branch segment opcode posn-encoding
- (reg-tn-encoding reg)
- (if cond 2 6) target nullify))))
+ (reg-tn-encoding reg)
+ (if cond 2 6) target nullify))))
\f
;;;; Computation Instructions
(byte 1 12) (byte 7 5) (byte 5 0))
(macrolet ((define-r3-inst (name cond-kind opcode)
- `(define-instruction ,name (segment r1 r2 res &optional cond)
- (:declare (type tn res r1 r2))
- (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
- cond-kind
- "-CONDITION"))))
- ,@(when (= opcode #x12)
- `((:printer r3-inst ((op ,opcode) (r2 0)
- (c nil :type ',(symbolicate cond-kind
- "-CONDITION")))
- `('COPY :tab r1 "," t))))
- (:emitter
- (multiple-value-bind
- (cond false)
- (,(symbolicate cond-kind "-CONDITION") cond)
- (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
- cond (if false 1 0) ,opcode
- (reg-tn-encoding res)))))))
+ `(define-instruction ,name (segment r1 r2 res &optional cond)
+ (:declare (type tn res r1 r2))
+ (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
+ cond-kind
+ "-CONDITION"))))
+ ,@(when (= opcode #x12)
+ `((:printer r3-inst ((op ,opcode) (r2 0)
+ (c nil :type ',(symbolicate cond-kind
+ "-CONDITION")))
+ `('COPY :tab r1 "," t))))
+ (:emitter
+ (multiple-value-bind
+ (cond false)
+ (,(symbolicate cond-kind "-CONDITION") cond)
+ (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
+ cond (if false 1 0) ,opcode
+ (reg-tn-encoding res)))))))
(define-r3-inst add add #x30)
(define-r3-inst addl add #x50)
(define-r3-inst addo add #x70)
(defun im11-encoding (value)
(declare (type (signed-byte 11) value)
- #+nil (values (unsigned-byte 11)))
+ #+nil (values (unsigned-byte 11)))
(dpb (ldb (byte 10 0) value)
(byte 10 1)
(ldb (byte 1 10) value)))
(macrolet ((define-imm-inst (name cond-kind opcode subcode)
- `(define-instruction ,name (segment imm src dst &optional cond)
- (:declare (type tn dst src)
- (type (signed-byte 11) imm))
- (:printer imm-inst ((op ,opcode) (o ,subcode)
- (c nil :type
- ',(symbolicate cond-kind "-CONDITION"))))
- (:emitter
- (multiple-value-bind
- (cond false)
- (,(symbolicate cond-kind "-CONDITION") cond)
- (emit-imm-inst segment ,opcode (reg-tn-encoding src)
- (reg-tn-encoding dst) cond
- (if false 1 0) ,subcode
- (im11-encoding imm)))))))
+ `(define-instruction ,name (segment imm src dst &optional cond)
+ (:declare (type tn dst src)
+ (type (signed-byte 11) imm))
+ (:printer imm-inst ((op ,opcode) (o ,subcode)
+ (c nil :type
+ ',(symbolicate cond-kind "-CONDITION"))))
+ (:emitter
+ (multiple-value-bind
+ (cond false)
+ (,(symbolicate cond-kind "-CONDITION") cond)
+ (emit-imm-inst segment ,opcode (reg-tn-encoding src)
+ (reg-tn-encoding dst) cond
+ (if false 1 0) ,subcode
+ (im11-encoding imm)))))))
(define-imm-inst addi add #x2D 0)
(define-imm-inst addio add #x2D 1)
(define-imm-inst addit add #x2C 0)
(define-instruction shd (segment r1 r2 count res &optional cond)
(:declare (type tn res r1 r2)
- (type (or (member :variable) (integer 0 31)) count))
+ (type (or (member :variable) (integer 0 31)) count))
(:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
- '(:name c :tab r1 "," r2 "," cp "," t/clen))
+ '(:name c :tab r1 "," r2 "," cp "," t/clen))
(:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
- '('VSHD c :tab r1 "," r2 "," t/clen))
+ '('VSHD c :tab r1 "," r2 "," t/clen))
(:emitter
(etypecase count
((member :variable)
(emit-extract/deposit-inst segment #x34
- (reg-tn-encoding r2) (reg-tn-encoding r1)
- (extract/deposit-condition cond)
- 0 0 (reg-tn-encoding res)))
+ (reg-tn-encoding r2) (reg-tn-encoding r1)
+ (extract/deposit-condition cond)
+ 0 0 (reg-tn-encoding res)))
((integer 0 31)
(emit-extract/deposit-inst segment #x34
- (reg-tn-encoding r2) (reg-tn-encoding r1)
- (extract/deposit-condition cond)
- 2 (- 31 count)
- (reg-tn-encoding res))))))
+ (reg-tn-encoding r2) (reg-tn-encoding r1)
+ (extract/deposit-condition cond)
+ 2 (- 31 count)
+ (reg-tn-encoding res))))))
(macrolet ((define-extract-inst (name opcode)
- `(define-instruction ,name (segment src posn len res &optional cond)
- (:declare (type tn res src)
- (type (or (member :variable) (integer 0 31)) posn)
- (type (integer 1 32) len))
- (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
- (op2 ,opcode))
- '(:name c :tab r2 "," cp "," t/clen "," r1))
- (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
- '('V :name c :tab r2 "," t/clen "," r1))
- (:emitter
- (etypecase posn
- ((member :variable)
- (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
- (reg-tn-encoding res)
- (extract/deposit-condition cond)
- ,(- opcode 2) 0 (- 32 len)))
- ((integer 0 31)
- (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
- (reg-tn-encoding res)
- (extract/deposit-condition cond)
- ,opcode posn (- 32 len))))))))
+ `(define-instruction ,name (segment src posn len res &optional cond)
+ (:declare (type tn res src)
+ (type (or (member :variable) (integer 0 31)) posn)
+ (type (integer 1 32) len))
+ (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
+ (op2 ,opcode))
+ '(:name c :tab r2 "," cp "," t/clen "," r1))
+ (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
+ '('V :name c :tab r2 "," t/clen "," r1))
+ (:emitter
+ (etypecase posn
+ ((member :variable)
+ (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
+ (reg-tn-encoding res)
+ (extract/deposit-condition cond)
+ ,(- opcode 2) 0 (- 32 len)))
+ ((integer 0 31)
+ (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
+ (reg-tn-encoding res)
+ (extract/deposit-condition cond)
+ ,opcode posn (- 32 len))))))))
(define-extract-inst extru 6)
(define-extract-inst extrs 7))
(macrolet ((define-deposit-inst (name opcode)
- `(define-instruction ,name (segment src posn len res &optional cond)
- (:declare (type tn res)
- (type (or tn (signed-byte 5)) src)
- (type (or (member :variable) (integer 0 31)) posn)
- (type (integer 1 32) len))
- (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
- ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
- (if (= opcode 0) (cons ''Z base) base)))
- (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
- ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
- (if (= opcode 0) (cons ''Z base) base)))
- (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
- (op2 ,(+ 4 opcode)))
- ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
- (if (= opcode 0) (cons ''Z base) base)))
- (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
- (op2 ,(+ 6 opcode)))
- ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
- (if (= opcode 0) (cons ''Z base) base)))
- (:emitter
- (multiple-value-bind
- (opcode src-encoding)
- (etypecase src
- (tn
- (values ,opcode (reg-tn-encoding src)))
- ((signed-byte 5)
- (values ,(+ opcode 4) (im5-encoding src))))
- (multiple-value-bind
- (opcode posn-encoding)
- (etypecase posn
- ((member :variable)
- (values opcode 0))
- ((integer 0 31)
- (values (+ opcode 2) (- 31 posn))))
- (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
- src-encoding
- (extract/deposit-condition cond)
- opcode posn-encoding (- 32 len))))))))
-
+ `(define-instruction ,name (segment src posn len res &optional cond)
+ (:declare (type tn res)
+ (type (or tn (signed-byte 5)) src)
+ (type (or (member :variable) (integer 0 31)) posn)
+ (type (integer 1 32) len))
+ (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
+ ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
+ ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
+ (op2 ,(+ 4 opcode)))
+ ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
+ (op2 ,(+ 6 opcode)))
+ ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:emitter
+ (multiple-value-bind
+ (opcode src-encoding)
+ (etypecase src
+ (tn
+ (values ,opcode (reg-tn-encoding src)))
+ ((signed-byte 5)
+ (values ,(+ opcode 4) (im5-encoding src))))
+ (multiple-value-bind
+ (opcode posn-encoding)
+ (etypecase posn
+ ((member :variable)
+ (values opcode 0))
+ ((integer 0 31)
+ (values (+ opcode 2) (- 31 posn))))
+ (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
+ src-encoding
+ (extract/deposit-condition cond)
+ opcode posn-encoding (- 32 len))))))))
+
(define-deposit-inst dep 1)
(define-deposit-inst zdep 0))
(define-instruction break (segment &optional (im5 0) (im13 0))
(:declare (type (unsigned-byte 13) im13)
- (type (unsigned-byte 5) im5))
+ (type (unsigned-byte 5) im5))
(:printer break () :default :control #'break-control)
(:emitter
(emit-break segment 0 im13 0 im5)))
(define-instruction ldsid (segment res base &optional (space 0))
(:declare (type tn res base)
- (type (integer 0 3) space))
+ (type (integer 0 3) space))
(:printer system-inst ((op2 #x85) (c nil :type 'space)
- (s nil :printer #(0 0 1 1 2 2 3 3)))
- `(:name :tab "(" s r1 ")," r3))
+ (s nil :printer #(0 0 1 1 2 2 3 3)))
+ `(:name :tab "(" s r1 ")," r3))
(:emitter
(emit-system-inst segment 0 (reg-tn-encoding base) 0 (ash space 1) #x85
- (reg-tn-encoding res))))
+ (reg-tn-encoding res))))
(define-instruction mtsp (segment reg space)
(:declare (type tn reg) (type (integer 0 7) space))
(:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
(:emitter
(emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
- #xC1 0)))
+ #xC1 0)))
(define-instruction mfsp (segment space reg)
(:declare (type tn reg) (type (integer 0 7) space))
(:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
(:emitter
(emit-system-inst segment 0 0 0 (space-encoding space) #x25
- (reg-tn-encoding reg))))
+ (reg-tn-encoding reg))))
(deftype control-reg ()
'(or (unsigned-byte 5) (member :sar)))
(defun control-reg (reg)
(declare (type control-reg reg)
- #+nil (values (unsigned-byte 32)))
+ #+nil (values (unsigned-byte 32)))
(if (typep reg '(unsigned-byte 5))
reg
(ecase reg
- (:sar 11))))
+ (:sar 11))))
(define-instruction mtctl (segment reg ctrl-reg)
(:declare (type tn reg) (type control-reg ctrl-reg))
(:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
(:emitter
(emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
- 0 #xC2 0)))
+ 0 #xC2 0)))
(define-instruction mfctl (segment ctrl-reg reg)
(:declare (type tn reg) (type control-reg ctrl-reg))
(:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
(:emitter
(emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
- (reg-tn-encoding reg))))
+ (reg-tn-encoding reg))))
\f
(define-instruction fldx (segment index base result &key modify scale side)
(:declare (type tn index base result)
- (type (member t nil) modify scale)
- (type (member nil 0 1) side))
+ (type (member t nil) modify scale)
+ (type (member nil 0 1) side))
(:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
- `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
+ `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
(:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
- `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
+ `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
(:emitter
(multiple-value-bind
(result-encoding double-p)
(aver double-p)
(setf double-p nil))
(emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
- (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
- (or side 0) (if modify 1 0) result-encoding))))
+ (reg-tn-encoding index) 0 (if scale 1 0) 0 0 0
+ (or side 0) (if modify 1 0) result-encoding))))
(define-instruction fstx (segment value index base &key modify scale side)
(:declare (type tn index base value)
- (type (member t nil) modify scale)
- (type (member nil 0 1) side))
+ (type (member t nil) modify scale)
+ (type (member nil 0 1) side))
(:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
- `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
+ `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
(:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
- `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
+ `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
(:emitter
(multiple-value-bind
(value-encoding double-p)
(aver double-p)
(setf double-p nil))
(emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
- (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
- (or side 0) (if modify 1 0) value-encoding))))
-
+ (reg-tn-encoding index) 0 (if scale 1 0) 0 0 1
+ (or side 0) (if modify 1 0) value-encoding))))
+
(define-instruction flds (segment disp base result &key modify side)
(:declare (type tn base result)
- (type (signed-byte 5) disp)
- (type (member :before :after nil) modify)
- (type (member nil 0 1) side))
+ (type (signed-byte 5) disp)
+ (type (member :before :after nil) modify)
+ (type (member nil 0 1) side))
(:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
- `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
+ `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
(:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
- `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t))
+ `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t))
(:emitter
(multiple-value-bind
(result-encoding double-p)
(aver double-p)
(setf double-p nil))
(emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
- (short-disp-encoding segment disp) 0
- (if (eq modify :before) 1 0) 1 0 0
- (or side 0) (if modify 1 0) result-encoding))))
+ (short-disp-encoding segment disp) 0
+ (if (eq modify :before) 1 0) 1 0 0
+ (or side 0) (if modify 1 0) result-encoding))))
(define-instruction fsts (segment value disp base &key modify side)
(:declare (type tn base value)
- (type (signed-byte 5) disp)
- (type (member :before :after nil) modify)
- (type (member nil 0 1) side))
+ (type (signed-byte 5) disp)
+ (type (member :before :after nil) modify)
+ (type (member nil 0 1) side))
(:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
- `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
+ `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
(:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
- `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
+ `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
(:emitter
(multiple-value-bind
(value-encoding double-p)
(aver double-p)
(setf double-p nil))
(emit-fp-load/store segment (if double-p #x0B #x09) (reg-tn-encoding base)
- (short-disp-encoding segment disp) 0
- (if (eq modify :before) 1 0) 1 0 1
- (or side 0) (if modify 1 0) value-encoding))))
+ (short-disp-encoding segment disp) 0
+ (if (eq modify :before) 1 0) 1 0 1
+ (or side 0) (if modify 1 0) value-encoding))))
(define-bitfield-emitter emit-fp-class-0-inst 32
(define-instruction funop (segment op from to)
(:declare (type funop op)
- (type tn from to))
+ (type tn from to))
(:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
- '('FCPY fmt :tab r "," t))
+ '('FCPY fmt :tab r "," t))
(:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
- '('FABS fmt :tab r "," t))
+ '('FABS fmt :tab r "," t))
(:printer fp-class-0-inst ((op1 #x0C) (op2 4) (x2 0))
- '('FSQRT fmt :tab r "," t))
+ '('FSQRT fmt :tab r "," t))
(:printer fp-class-0-inst ((op1 #x0C) (op2 5) (x2 0))
- '('FRND fmt :tab r "," t))
+ '('FRND fmt :tab r "," t))
(:emitter
(multiple-value-bind
(from-encoding from-double-p)
(fp-reg-tn-encoding from)
(multiple-value-bind
- (to-encoding to-double-p)
- (fp-reg-tn-encoding to)
+ (to-encoding to-double-p)
+ (fp-reg-tn-encoding to)
(aver (eq from-double-p to-double-p))
(emit-fp-class-0-inst segment #x0C from-encoding 0
- (+ 2 (or (position op funops)
- (error "Bogus FUNOP: ~S" op)))
- (if to-double-p 1 0) 0 0 0 to-encoding)))))
+ (+ 2 (or (position op funops)
+ (error "Bogus FUNOP: ~S" op)))
+ (if to-double-p 1 0) 0 0 0 to-encoding)))))
(macrolet ((define-class-1-fp-inst (name subcode)
- `(define-instruction ,name (segment from to)
- (:declare (type tn from to))
- (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
- '(:name sf df :tab r "," t))
- (:emitter
- (multiple-value-bind
- (from-encoding from-double-p)
- (fp-reg-tn-encoding from)
- (multiple-value-bind
- (to-encoding to-double-p)
- (fp-reg-tn-encoding to)
- (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
- (if to-double-p 1 0) (if from-double-p 1 0)
- 1 0 0 to-encoding)))))))
-
+ `(define-instruction ,name (segment from to)
+ (:declare (type tn from to))
+ (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
+ '(:name sf df :tab r "," t))
+ (:emitter
+ (multiple-value-bind
+ (from-encoding from-double-p)
+ (fp-reg-tn-encoding from)
+ (multiple-value-bind
+ (to-encoding to-double-p)
+ (fp-reg-tn-encoding to)
+ (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
+ (if to-double-p 1 0) (if from-double-p 1 0)
+ 1 0 0 to-encoding)))))))
+
(define-class-1-fp-inst fcnvff 0)
(define-class-1-fp-inst fcnvxf 1)
(define-class-1-fp-inst fcnvfx 2)
(define-instruction fcmp (segment cond r1 r2)
(:declare (type (unsigned-byte 5) cond)
- (type tn r1 r2))
+ (type tn r1 r2))
(:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
- '(:name fmt t :tab r "," x1))
+ '(:name fmt t :tab r "," x1))
(:emitter
(multiple-value-bind
(r1-encoding r1-double-p)
(fp-reg-tn-encoding r1)
(multiple-value-bind
- (r2-encoding r2-double-p)
- (fp-reg-tn-encoding r2)
+ (r2-encoding r2-double-p)
+ (fp-reg-tn-encoding r2)
(aver (eq r1-double-p r2-double-p))
(emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding 0
- (if r1-double-p 1 0) 2 0 0 cond)))))
+ (if r1-double-p 1 0) 2 0 0 cond)))))
(define-instruction ftest (segment)
(:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
(define-instruction fbinop (segment op r1 r2 result)
(:declare (type fbinop op)
- (type tn r1 r2 result))
+ (type tn r1 r2 result))
(:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
- '('FADD fmt :tab r "," x1 "," t))
+ '('FADD fmt :tab r "," x1 "," t))
(:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
- '('FSUB fmt :tab r "," x1 "," t))
+ '('FSUB fmt :tab r "," x1 "," t))
(:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 3))
- '('FMPY fmt :tab r "," x1 "," t))
+ '('FMPY fmt :tab r "," x1 "," t))
(:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 3))
- '('FDIV fmt :tab r "," x1 "," t))
+ '('FDIV fmt :tab r "," x1 "," t))
(:emitter
(multiple-value-bind
(r1-encoding r1-double-p)
(fp-reg-tn-encoding r1)
(multiple-value-bind
- (r2-encoding r2-double-p)
- (fp-reg-tn-encoding r2)
+ (r2-encoding r2-double-p)
+ (fp-reg-tn-encoding r2)
(aver (eq r1-double-p r2-double-p))
(multiple-value-bind
- (result-encoding result-double-p)
- (fp-reg-tn-encoding result)
- (aver (eq r1-double-p result-double-p))
- (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
- (or (position op fbinops)
- (error "Bogus FBINOP: ~S" op))
- (if r1-double-p 1 0) 3 0 0
- result-encoding))))))
+ (result-encoding result-double-p)
+ (fp-reg-tn-encoding result)
+ (aver (eq r1-double-p result-double-p))
+ (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
+ (or (position op fbinops)
+ (error "Bogus FBINOP: ~S" op))
+ (if r1-double-p 1 0) 3 0 0
+ result-encoding))))))
\f
(define-instruction li (segment value reg)
(:declare (type tn reg)
- (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
+ (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
(:vop-var vop)
(:emitter
(assemble (segment vop)
(etypecase value
(fixup
- (inst ldil value reg)
- (inst ldo value reg reg))
+ (inst ldil value reg)
+ (inst ldo value reg reg))
((signed-byte 14)
- (inst ldo value zero-tn reg))
+ (inst ldo value zero-tn reg))
((or (signed-byte 32) (unsigned-byte 32))
- (let ((hi (ldb (byte 21 11) value))
- (lo (ldb (byte 11 0) value)))
- (inst ldil hi reg)
- (unless (zerop lo)
- (inst ldo lo reg reg))))))))
+ (let ((hi (ldb (byte 21 11) value))
+ (lo (ldb (byte 11 0) value)))
+ (inst ldil hi reg)
+ (unless (zerop lo)
+ (inst ldo lo reg reg))))))))
(define-instruction-macro sll (src count result &optional cond)
(once-only ((result result) (src src) (count count) (cond cond))
(defun maybe-negate-cond (cond negate)
(if negate
(multiple-value-bind
- (value negate)
- (compare-condition cond)
- (if negate
- (nth value compare-conditions)
- (nth (+ value 8) compare-conditions)))
+ (value negate)
+ (compare-condition cond)
+ (if negate
+ (nth value compare-conditions)
+ (nth (+ value 8) compare-conditions)))
cond))
(define-instruction bc (segment cond not-p r1 r2 target)
(:declare (type compare-condition cond)
- (type (member t nil) not-p)
- (type tn r1 r2)
- (type label target))
+ (type (member t nil) not-p)
+ (type tn r1 r2)
+ (type label target))
(:vop-var vop)
(:emitter
(emit-chooser segment 8 2
#'(lambda (segment posn delta)
- (let ((disp (label-relative-displacement target posn delta)))
- (when (<= 0 disp (1- (ash 1 11)))
- (assemble (segment vop)
- (inst comb (maybe-negate-cond cond not-p) r1 r2 target
- :nullify t))
- t)))
+ (let ((disp (label-relative-displacement target posn delta)))
+ (when (<= 0 disp (1- (ash 1 11)))
+ (assemble (segment vop)
+ (inst comb (maybe-negate-cond cond not-p) r1 r2 target
+ :nullify t))
+ t)))
#'(lambda (segment posn)
- (let ((disp (label-relative-displacement target posn)))
- (assemble (segment vop)
- (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
- (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
- (inst nop))
- (t
- (inst comclr r1 r2 zero-tn
- (maybe-negate-cond cond (not not-p)))
- (inst b target :nullify t)))))))))
+ (let ((disp (label-relative-displacement target posn)))
+ (assemble (segment vop)
+ (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
+ (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
+ (inst nop))
+ (t
+ (inst comclr r1 r2 zero-tn
+ (maybe-negate-cond cond (not not-p)))
+ (inst b target :nullify t)))))))))
(define-instruction bci (segment cond not-p imm reg target)
(:declare (type compare-condition cond)
- (type (member t nil) not-p)
- (type (signed-byte 11) imm)
- (type tn reg)
- (type label target))
+ (type (member t nil) not-p)
+ (type (signed-byte 11) imm)
+ (type tn reg)
+ (type label target))
(:vop-var vop)
(:emitter
(emit-chooser segment 8 2
#'(lambda (segment posn delta-if-after)
- (let ((disp (label-relative-displacement target posn delta-if-after)))
- (when (and (<= 0 disp (1- (ash 1 11)))
- (<= (- (ash 1 4)) imm (1- (ash 1 4))))
- (assemble (segment vop)
- (inst comib (maybe-negate-cond cond not-p) imm reg target
- :nullify t))
- t)))
+ (let ((disp (label-relative-displacement target posn delta-if-after)))
+ (when (and (<= 0 disp (1- (ash 1 11)))
+ (<= (- (ash 1 4)) imm (1- (ash 1 4))))
+ (assemble (segment vop)
+ (inst comib (maybe-negate-cond cond not-p) imm reg target
+ :nullify t))
+ t)))
#'(lambda (segment posn)
- (let ((disp (label-relative-displacement target posn)))
- (assemble (segment vop)
- (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
- (<= (- (ash 1 4)) imm (1- (ash 1 4))))
- (inst comib (maybe-negate-cond cond not-p) imm reg target)
- (inst nop))
- (t
- (inst comiclr imm reg zero-tn
- (maybe-negate-cond cond (not not-p)))
- (inst b target :nullify t)))))))))
+ (let ((disp (label-relative-displacement target posn)))
+ (assemble (segment vop)
+ (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
+ (<= (- (ash 1 4)) imm (1- (ash 1 4))))
+ (inst comib (maybe-negate-cond cond not-p) imm reg target)
+ (inst nop))
+ (t
+ (inst comiclr imm reg zero-tn
+ (maybe-negate-cond cond (not not-p)))
+ (inst b target :nullify t)))))))))
\f
;;;; Instructions to convert between code ptrs, functions, and lras.
;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
segment 12 3
#'(lambda (segment posn delta-if-after)
- (let ((delta (funcall calc label posn delta-if-after)))
- (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
- (emit-back-patch segment 4
- #'(lambda (segment posn)
- (assemble (segment vop)
- (inst addi (funcall calc label posn 0) src
- dst))))
- t)))
+ (let ((delta (funcall calc label posn delta-if-after)))
+ (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (assemble (segment vop)
+ (inst addi (funcall calc label posn 0) src
+ dst))))
+ t)))
#'(lambda (segment posn)
- (let ((delta (funcall calc label posn 0)))
- ;; Note: if we used addil/ldo to do this in 2 instructions then the
- ;; intermediate value would be tagged but pointing into space.
- (assemble (segment vop)
- (inst ldil (ldb (byte 21 11) delta) temp)
- (inst ldo (ldb (byte 11 0) delta) temp temp)
- (inst add src temp dst))))))
+ (let ((delta (funcall calc label posn 0)))
+ ;; Note: if we used addil/ldo to do this in 2 instructions then the
+ ;; intermediate value would be tagged but pointing into space.
+ (assemble (segment vop)
+ (inst ldil (ldb (byte 21 11) delta) temp)
+ (inst ldo (ldb (byte 11 0) delta) temp temp)
+ (inst add src temp dst))))))
;; code = fn - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-fn (segment src label temp dst)
(:declare (type tn src dst temp)
- (type label label))
+ (type label label))
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop src label temp dst
- #'(lambda (label posn delta-if-after)
- (- other-pointer-lowtag
- (label-position label posn delta-if-after)
- (component-header-length))))))
+ #'(lambda (label posn delta-if-after)
+ (- other-pointer-lowtag
+ (label-position label posn delta-if-after)
+ (component-header-length))))))
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-lra (segment src label temp dst)
(:declare (type tn src dst temp)
- (type label label))
+ (type label label))
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop src label temp dst
- #'(lambda (label posn delta-if-after)
- (- (+ (label-position label posn delta-if-after)
- (component-header-length)))))))
+ #'(lambda (label posn delta-if-after)
+ (- (+ (label-position label posn delta-if-after)
+ (component-header-length)))))))
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
(define-instruction compute-lra-from-code (segment src label temp dst)
(:declare (type tn src dst temp)
- (type label label))
+ (type label label))
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop src label temp dst
- #'(lambda (label posn delta-if-after)
- (+ (label-position label posn delta-if-after)
- (component-header-length))))))
+ #'(lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length))))))
\f
;;;; Data instructions.
(emit-back-patch
segment 4
#'(lambda (segment posn)
- (emit-word segment
- (logior simple-fun-header-widetag
- (ash (+ posn (component-header-length))
- (- n-widetag-bits word-shift))))))))
+ (emit-word segment
+ (logior simple-fun-header-widetag
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift))))))))
(define-instruction lra-header-word (segment)
(:emitter
(emit-back-patch
segment 4
#'(lambda (segment posn)
- (emit-word segment
- (logior return-pc-header-widetag
- (ash (+ posn (component-header-length))
- (- n-widetag-bits word-shift))))))))
+ (emit-word segment
+ (logior return-pc-header-widetag
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift))))))))
(defmacro load-symbol-value (reg symbol)
`(inst ldw
- (+ (static-symbol-offset ',symbol)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag))
- null-tn
- ,reg))
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag))
+ null-tn
+ ,reg))
(defmacro store-symbol-value (reg symbol)
`(inst stw ,reg (+ (static-symbol-offset ',symbol)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag))
- null-tn))
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag))
+ null-tn))
(defmacro load-type (target source &optional (offset 0))
"Loads the type bits of a pointer into target independent of
`(inst ldb (+ ,offset 3) ,source ,target))))
;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions.
+;;; return instructions.
(defmacro lisp-jump (function)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
(inst addi
- (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
- ,function
- lip-tn)
+ (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
+ ,function
+ lip-tn)
(inst bv lip-tn)
(move ,function code-tn)))
"Return to RETURN-PC."
`(progn
(inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
- ,return-pc lip-tn)
+ ,return-pc lip-tn)
(inst bv lip-tn ,@(unless frob-code '(:nullify t)))
,@(when frob-code
- `((move ,return-pc code-tn)))))
+ `((move ,return-pc code-tn)))))
(defmacro emit-return-pc (label)
"Emit a return-pc header word. LABEL is the label to use for this
;;; Move a stack TN to a register and vice-versa.
(defmacro load-stack-tn (reg stack)
`(let ((reg ,reg)
- (stack ,stack))
+ (stack ,stack))
(let ((offset (tn-offset stack)))
(sc-case stack
- ((control-stack)
- (loadw reg cfp-tn offset))))))
+ ((control-stack)
+ (loadw reg cfp-tn offset))))))
(defmacro store-stack-tn (stack reg)
`(let ((stack ,stack)
- (reg ,reg))
+ (reg ,reg))
(let ((offset (tn-offset stack)))
(sc-case stack
- ((control-stack)
- (storew reg cfp-tn offset))))))
+ ((control-stack)
+ (storew reg cfp-tn offset))))))
(defmacro maybe-load-stack-tn (reg reg-or-stack)
"Move the TN Reg-Or-Stack into Reg if it isn't already there."
(once-only ((n-reg reg)
- (n-stack reg-or-stack))
+ (n-stack reg-or-stack))
`(sc-case ,n-reg
((any-reg descriptor-reg)
- (sc-case ,n-stack
- ((any-reg descriptor-reg)
- (move ,n-stack ,n-reg))
- ((control-stack)
- (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+ (sc-case ,n-stack
+ ((any-reg descriptor-reg)
+ (move ,n-stack ,n-reg))
+ ((control-stack)
+ (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
\f
;;;; Storage allocation:
(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
- &body body)
+ &body body)
"Do stuff to allocate an other-pointer object of fixed Size with a single
word header having the specified Type-Code. The result is placed in
Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
(unless body
(bug "empty &body in WITH-FIXED-ALLOCATION"))
(once-only ((result-tn result-tn) (temp-tn temp-tn)
- (type-code type-code) (size size))
+ (type-code type-code) (size size))
`(pseudo-atomic (:extra (pad-data-block ,size))
(inst move alloc-tn ,result-tn)
(inst dep other-pointer-lowtag 31 3 ,result-tn)
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
`((let ((vop ,vop))
- (when vop
- (note-this-location vop :internal-error)))
- (inst break ,kind)
- (with-adjustable-vector (,vector)
- (write-var-integer (error-number-or-lose ',code) ,vector)
- ,@(mapcar #'(lambda (tn)
- `(let ((tn ,tn))
- (write-var-integer (make-sc-offset (sc-number
- (tn-sc tn))
- (tn-offset tn))
- ,vector)))
- values)
- (inst byte (length ,vector))
- (dotimes (i (length ,vector))
- (inst byte (aref ,vector i))))
- (align word-shift)))))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst break ,kind)
+ (with-adjustable-vector (,vector)
+ (write-var-integer (error-number-or-lose ',code) ,vector)
+ ,@(mapcar #'(lambda (tn)
+ `(let ((tn ,tn))
+ (write-var-integer (make-sc-offset (sc-number
+ (tn-sc tn))
+ (tn-offset tn))
+ ,vector)))
+ values)
+ (inst byte (length ,vector))
+ (dotimes (i (length ,vector))
+ (inst byte (aref ,vector i))))
+ (align word-shift)))))
(defmacro error-call (vop error-code &rest values)
"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 cerror-call (vop label error-code &rest values)
`(let ((,continue (gen-label)))
(emit-label ,continue)
(assemble (*elsewhere*)
- (let ((,error (gen-label)))
- (emit-label ,error)
- (cerror-call ,vop ,continue ,error-code ,@values)
- ,error)))))
+ (let ((,error (gen-label)))
+ (emit-label ,error)
+ (cerror-call ,vop ,continue ,error-code ,@values)
+ ,error)))))
\f
;;;; PSEUDO-ATOMIC
;;;; indexed references
(deftype load/store-index (scale lowtag min-offset
- &optional (max-offset min-offset))
+ &optional (max-offset min-offset))
`(integer ,(- (truncate (+ (ash 1 14)
- (* min-offset n-word-bytes)
- (- lowtag))
- scale))
- ,(truncate (- (+ (1- (ash 1 14)) lowtag)
- (* max-offset n-word-bytes))
- scale)))
+ (* min-offset n-word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 14)) lowtag)
+ (* max-offset n-word-bytes))
+ scale)))
(defmacro define-full-reffer (name type offset lowtag scs el-type
- &optional translate)
+ &optional translate)
`(progn
(define-vop (,name)
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (any-reg) :target temp))
+ (index :scs (any-reg) :target temp))
(:arg-types ,type tagged-num)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 5
- (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
- (inst ldwx temp object value)))
+ (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
+ (inst ldwx temp object value)))
(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 4
- (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
- object value)))))
+ (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
+ object value)))))
(defmacro define-full-setter (name type offset lowtag scs el-type
- &optional translate)
+ &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)
(:temporary (:scs (interior-reg)) lip)
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 2
- (inst add object index lip)
- (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
- (move value result)))
+ (inst add object index lip)
+ (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
+ (move value result)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
- `((:translate ,translate)))
+ `((:translate ,translate)))
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (value :scs ,scs))
+ (value :scs ,scs))
(: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 1
- (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
- (move value result)))))
+ (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
+ (move value result)))))
(defmacro define-partial-reffer (name type size signed offset lowtag scs
- el-type &optional translate)
+ el-type &optional translate)
(let ((scale (ecase size (:byte 1) (:short 2))))
`(progn
(define-vop (,name)
- ,@(when translate
- `((:translate ,translate)))
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg) :to (:eval 0))
- (index :scs (unsigned-reg)))
- (:arg-types ,type positive-fixnum)
- (:results (value :scs ,scs))
- (:result-types ,el-type)
- (:temporary (:scs (interior-reg)) lip)
- (:generator 5
- (inst ,(ecase size (:byte 'add) (:short 'sh1add))
- index object lip)
- (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
- (- (* ,offset n-word-bytes) ,lowtag) lip value)
- ,@(when signed
- `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 5
+ (inst ,(ecase size (:byte 'add) (:short 'sh1add))
+ index object lip)
+ (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
+ (- (* ,offset n-word-bytes) ,lowtag) lip value)
+ ,@(when signed
+ `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
(define-vop (,(symbolicate name "-C"))
- ,@(when translate
- `((:translate ,translate)))
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:info index)
- (:arg-types ,type
- (:constant (load/store-index ,scale
- ,(eval lowtag)
- ,(eval offset))))
- (:results (value :scs ,scs))
- (:result-types ,el-type)
- (:generator 5
- (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
- (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
- object value)
- ,@(when signed
- `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset))))
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
+ object value)
+ ,@(when signed
+ `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
(defmacro define-partial-setter (name type size offset lowtag scs el-type
- &optional translate)
+ &optional translate)
(let ((scale (ecase size (:byte 1) (:short 2))))
`(progn
(define-vop (,name)
- ,@(when translate
- `((:translate ,translate)))
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg))
- (value :scs ,scs :target result))
- (:arg-types ,type positive-fixnum ,el-type)
- (:temporary (:scs (interior-reg)) lip)
- (:results (result :scs ,scs))
- (:result-types ,el-type)
- (:generator 5
- (inst ,(ecase size (:byte 'add) (:short 'sh1add))
- index object lip)
- (inst ,(ecase size (:byte 'stb) (:short 'sth))
- value (- (* ,offset n-word-bytes) ,lowtag) lip)
- (move value result)))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg))
+ (value :scs ,scs :target result))
+ (:arg-types ,type positive-fixnum ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size (:byte 'add) (:short 'sh1add))
+ index object lip)
+ (inst ,(ecase size (:byte 'stb) (:short 'sth))
+ value (- (* ,offset n-word-bytes) ,lowtag) lip)
+ (move value result)))
(define-vop (,(symbolicate name "-C"))
- ,@(when translate
- `((:translate ,translate)))
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (value :scs ,scs :target result))
- (:info index)
- (:arg-types ,type
- (:constant (load/store-index ,scale
- ,(eval lowtag)
- ,(eval offset)))
- ,el-type)
- (:results (result :scs ,scs))
- (:result-types ,el-type)
- (:generator 5
- (inst ,(ecase size (:byte 'stb) (:short 'sth))
- value
- (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
- object)
- (move value result))))))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs ,scs :target result))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset)))
+ ,el-type)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst ,(ecase size (:byte 'stb) (:short 'sth))
+ value
+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
+ object)
+ (move value result))))))
(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
garbage collection. This is currently implemented by disabling GC"
- (declare (ignore objects)) ;should we eval these for side-effect?
+ (declare (ignore objects)) ;should we eval these for side-effect?
`(without-gcing
,@body))
;;;
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
+ (value :scs (descriptor-reg any-reg)))
(:variant-vars base lowtag)
(:info offset)
(:generator 1
(load-symbol y val))
(character
(inst li (logior (ash (char-code val) n-widetag-bits)
- character-widetag)
- y)))))
+ character-widetag)
+ y)))))
(define-move-fun (load-number 1) (vop x y)
((immediate zero)
;;;; The Move VOP:
(define-vop (move)
(:args (x :target y
- :scs (any-reg descriptor-reg)
- :load-if (not (location= x y))))
+ :scs (any-reg descriptor-reg)
+ :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))))
(:effects)
(:affected)
(:generator 0
;;; frame for argument or known value passing.
(define-vop (move-arg)
(:args (x :target y
- :scs (any-reg descriptor-reg))
- (fp :scs (any-reg)
- :load-if (not (sc-is y any-reg descriptor-reg))))
+ :scs (any-reg descriptor-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y any-reg descriptor-reg))))
(:results (y))
(:generator 0
(sc-case y
;;; Move untagged numbers.
(define-vop (word-move)
(:args (x :target y
- :scs (signed-reg unsigned-reg)
- :load-if (not (location= x y))))
+ :scs (signed-reg unsigned-reg)
+ :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))))
(:effects)
(:affected)
(:note "word integer move")
;;; Move untagged number args/return-values.
(define-vop (move-word-arg)
(:args (x :target y
- :scs (signed-reg unsigned-reg))
- (fp :scs (any-reg)
- :load-if (not (sc-is y sap-reg))))
+ :scs (signed-reg unsigned-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "word integer argument move")
(:generator 0
(define-vop (save-dynamic-state)
(:results (catch :scs (descriptor-reg))
- (nfp :scs (descriptor-reg))
- (nsp :scs (descriptor-reg)))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 13
(load-symbol-value catch *current-catch-block*)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (move cur-nfp nfp)))
+ (move cur-nfp nfp)))
(move nsp-tn nsp)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
- (nfp :scs (descriptor-reg))
- (nsp :scs (descriptor-reg)))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 10
(store-symbol-value catch *current-catch-block*)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (move nfp cur-nfp)))
+ (move nfp cur-nfp)))
(move nsp nsp-tn)))
(define-vop (current-stack-pointer)
;;;
(define-vop (make-catch-block)
(:args (tn)
- (tag :scs (any-reg descriptor-reg)))
+ (tag :scs (any-reg descriptor-reg)))
(:info entry-label)
(:results (block :scs (any-reg) :from (:argument 0)))
(:temporary (:scs (descriptor-reg)) temp)
(define-vop (nlx-entry)
(:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
- ; would be inserted before the LRA.
- (start)
- (count))
+ ; would be inserted before the LRA.
+ (start)
+ (count))
(:results (values :more t))
(:temporary (:scs (descriptor-reg)) move-temp)
(:info label nvals)
(emit-return-pc label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
- ((= nvals 1)
- (inst comclr count zero-tn zero-tn :<>)
- (inst move null-tn (tn-ref-tn values) :tr)
- (loadw (tn-ref-tn values) start))
- (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 bci := nil (fixnumize i) count default-lab)
- (sc-case tn
- ((descriptor-reg any-reg)
- (loadw tn start i))
- (control-stack
- (loadw move-temp start i)
- (store-stack-tn tn move-temp)))))
-
- (let ((defaulting-done (gen-label)))
- (emit-label defaulting-done)
-
- (assemble (*elsewhere*)
- (do ((defs (defaults) (cdr defs)))
- ((null defs))
- (let ((def (car defs)))
- (emit-label (car def))
- (unless (cdr defs)
- (inst b defaulting-done))
- (let ((tn (cdr def)))
- (sc-case tn
- ((descriptor-reg any-reg)
- (move null-tn tn))
- (control-stack
- (store-stack-tn tn null-tn)))))))))))
+ ((= nvals 1)
+ (inst comclr count zero-tn zero-tn :<>)
+ (inst move null-tn (tn-ref-tn values) :tr)
+ (loadw (tn-ref-tn values) start))
+ (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 bci := nil (fixnumize i) count default-lab)
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (loadw tn start i))
+ (control-stack
+ (loadw move-temp start i)
+ (store-stack-tn tn move-temp)))))
+
+ (let ((defaulting-done (gen-label)))
+ (emit-label defaulting-done)
+
+ (assemble (*elsewhere*)
+ (do ((defs (defaults) (cdr defs)))
+ ((null defs))
+ (let ((def (car defs)))
+ (emit-label (car def))
+ (unless (cdr defs)
+ (inst b defaulting-done))
+ (let ((tn (cdr def)))
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (move null-tn tn))
+ (control-stack
+ (store-stack-tn tn null-tn)))))))))))
(load-stack-tn csp-tn sp)))
(defconstant-eqx float-traps-byte (byte 5 0) #'equal)
(defconstant-eqx float-exceptions-byte (byte 5 27) #'equal)
(def!constant float-condition-bit (ash 1 26))
-(def!constant float-fast-bit 0) ; No fast mode on HPPA.
+(def!constant float-fast-bit 0) ; No fast mode on HPPA.
\f
;;;; Description of the target address space.
;;; Where to put the different spaces.
-;;;
+;;;
(def!constant read-only-space-start #x20000000)
(def!constant read-only-space-end #x24000000)
;; The C startup code must fill these in.
*posix-argv*
-
+
;; Functions that the C code needs to call
sb!impl::sub-gc
sb!kernel::internal-error
*binding-stack-start*
*control-stack-start*
*control-stack-end*
-
+
;; Interrupt Handling
*free-interrupt-context-index*
sb!unix::*interrupts-enabled*
(define-vop (if-eq)
(:args (x :scs (any-reg descriptor-reg zero null))
- (y :scs (any-reg descriptor-reg zero null)))
+ (y :scs (any-reg descriptor-reg zero null)))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
;;;; 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.
(defun sanctify-for-execution (component)
(without-gcing
(alien-funcall (extern-alien "sanctify_for_execution"
- (function void
- system-area-pointer
- unsigned-long))
- (code-instructions component)
- (* (code-header-ref component code-code-size-slot)
- n-word-bytes)))
+ (function void
+ system-area-pointer
+ unsigned-long))
+ (code-instructions component)
+ (* (code-header-ref component code-code-size-slot)
+ n-word-bytes)))
nil)
;;; 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))))
(:effects)
(:affected)
(:generator 0
;;; Move untagged sap args/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))
(:generator 0
(sc-case y
(define-vop (pointer+)
(:translate sap+)
(:args (ptr :scs (sap-reg) :target res)
- (offset :scs (signed-reg)))
+ (offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(define-vop (pointer-)
(:translate sap-)
(:args (ptr1 :scs (sap-reg))
- (ptr2 :scs (sap-reg)))
+ (ptr2 :scs (sap-reg)))
(:arg-types system-area-pointer system-area-pointer)
(:policy :fast-safe)
(:results (res :scs (signed-reg)))
\f
;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
(macrolet ((def-system-ref-and-set
- (ref-name set-name sc type size &optional signed)
+ (ref-name set-name sc type size &optional signed)
(let ((ref-name-c (symbolicate ref-name "-C"))
- (set-name-c (symbolicate set-name "-C")))
+ (set-name-c (symbolicate set-name "-C")))
`(progn
(define-vop (,ref-name)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (object :scs (sap-reg))
- (offset :scs (signed-reg)))
- (:arg-types system-area-pointer signed-num)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- (inst ,(ecase size
- (:byte 'ldbx)
- (:short 'ldhx)
- (:long 'ldwx)
- (:float 'fldx))
- offset object result)
- ,@(when (and signed (not (eq size :long)))
- `((inst extrs result 31 ,(ecase size
- (:byte 8)
- (:short 16))
- result)))))
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg))
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ (inst ,(ecase size
+ (:byte 'ldbx)
+ (:short 'ldhx)
+ (:long 'ldwx)
+ (:float 'fldx))
+ offset object result)
+ ,@(when (and signed (not (eq size :long)))
+ `((inst extrs result 31 ,(ecase size
+ (:byte 8)
+ (:short 16))
+ result)))))
(define-vop (,ref-name-c)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (object :scs (sap-reg)))
- (:arg-types system-area-pointer
- (:constant ,(if (eq size :float)
- '(signed-byte 5)
- '(signed-byte 14))))
- (:info offset)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- (inst ,(ecase size
- (:byte 'ldb)
- (:short 'ldh)
- (:long 'ldw)
- (:float 'flds))
- offset object result)
- ,@(when (and signed (not (eq size :long)))
- `((inst extrs result 31 ,(ecase size
- (:byte 8)
- (:short 16))
- result)))))
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :float)
+ '(signed-byte 5)
+ '(signed-byte 14))))
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ (inst ,(ecase size
+ (:byte 'ldb)
+ (:short 'ldh)
+ (:long 'ldw)
+ (:float 'flds))
+ offset object result)
+ ,@(when (and signed (not (eq size :long)))
+ `((inst extrs result 31 ,(ecase size
+ (:byte 8)
+ (:short 16))
+ result)))))
(define-vop (,set-name)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (object :scs (sap-reg)
- ,@(unless (eq size :float) '(:target sap)))
- (offset :scs (signed-reg))
- (value :scs (,sc) :target result))
- (:arg-types system-area-pointer signed-num ,type)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- ,@(unless (eq size :float)
- '((:temporary (:scs (sap-reg) :from (:argument 0)) sap)))
- (:generator 5
- ,@(if (eq size :float)
- `((inst fstx value offset object)
- (unless (location= value result)
- (inst funop :copy value result)))
- `((inst add object offset sap)
- (inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
- value 0 sap)
- (move value result)))))
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)
+ ,@(unless (eq size :float) '(:target sap)))
+ (offset :scs (signed-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer signed-num ,type)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ ,@(unless (eq size :float)
+ '((:temporary (:scs (sap-reg) :from (:argument 0)) sap)))
+ (:generator 5
+ ,@(if (eq size :float)
+ `((inst fstx value offset object)
+ (unless (location= value result)
+ (inst funop :copy value result)))
+ `((inst add object offset sap)
+ (inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
+ value 0 sap)
+ (move value result)))))
(define-vop (,set-name-c)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (object :scs (sap-reg))
- (value :scs (,sc) :target result))
- (:arg-types system-area-pointer
- (:constant ,(if (eq size :float)
- '(signed-byte 5)
- '(signed-byte 14)))
- ,type)
- (:info offset)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- ,@(if (eq size :float)
- `((inst fsts value offset object)
- (unless (location= value result)
- (inst funop :copy value result)))
- `((inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
- value offset object)
- (move value result)))))))))
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :float)
+ '(signed-byte 5)
+ '(signed-byte 14)))
+ ,type)
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(if (eq size :float)
+ `((inst fsts value offset object)
+ (unless (location= value result)
+ (inst funop :copy value result)))
+ `((inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
+ value offset object)
+ (move value result)))))))))
(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
unsigned-reg positive-fixnum :byte nil)
(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
(:result-types system-area-pointer)
(:generator 2
(inst addi
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
- vector
- sap)))
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
+ vector
+ sap)))
\f
;;; Transforms for 64-bit SAP accessors.
(deftransform sap-ref-64 ((sap offset) (* *))
'(logior (ash (sap-ref-32 sap offset) 32)
- (sap-ref-32 sap (+ offset 4))))
+ (sap-ref-32 sap (+ offset 4))))
(deftransform signed-sap-ref-64 ((sap offset) (* *))
'(logior (ash (signed-sap-ref-32 sap offset) 32)
- (sap-ref-32 sap (+ 4 offset))))
+ (sap-ref-32 sap (+ 4 offset))))
(deftransform %set-sap-ref-64 ((sap offset value) (* * *))
'(progn
(:save-p t)
(:temporary (:sc non-descriptor-reg :offset cfunc-offset) cfunc)
(:temporary (:sc non-descriptor-reg :offset nl0-offset :from (:argument 0))
- arg)
+ arg)
(:temporary (:sc non-descriptor-reg :offset nl4-offset :to (:result 0))
- res)
+ res)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:scs (non-descriptor-reg)) temp)
(:vop-var vop)
(let ((cur-nfp (current-nfp-tn vop)))
(move object arg)
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
;; Allocate 64 bytes, the minimum stack size.
(inst addi 64 nsp-tn nsp-tn)
(inst li (make-fixup "debug_print" :foreign) cfunc)
(let ((fixup (make-fixup "call_into_c" :foreign)))
- (inst ldil fixup temp)
- (inst ble fixup c-text-space temp :nullify t)
- (inst nop))
+ (inst ldil fixup temp)
+ (inst ble fixup c-text-space temp :nullify t)
+ (inst nop))
(inst addi -64 nsp-tn nsp-tn)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save))
+ (load-stack-tn cur-nfp nfp-save))
(move res result))))
(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 (src dst)
(collect ((moves))
(do ((src src (cdr src))
- (dst dst (cdr dst)))
- ((or (null src) (null dst)))
+ (dst dst (cdr dst)))
+ ((or (null src) (null dst)))
(moves `(move ,(car src) ,(car dst))))
(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*)
- ,@(when (< i num-args)
- `(:from (:argument ,i)))
- ,@(when (< i num-results)
- `(:to (:result ,i)
- :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*)
+ ,@(when (< i num-args)
+ `(:from (:argument ,i)))
+ ,@(when (< i num-results)
+ `(:to (:result ,i)
+ :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)
- (let ((lra-label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
- ,@(moves (arg-names) (temp-names))
- (inst li (fixnumize ,num-args) nargs)
- (inst ldw (static-fun-offset symbol) null-tn lip)
- (when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
- (inst move cfp-tn old-fp)
- (inst compute-lra-from-code code-tn lra-label temp lra)
- (note-this-location vop :call-site)
- (inst bv lip)
- (inst move csp-tn cfp-tn)
- (emit-return-pc lra-label)
- ,(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 move-temp temp lra-label)))
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))
- ,@(moves (temp-names) (result-names))))))))
+ static-fun-template)
+ (:args ,@(args))
+ ,@(temps)
+ (:results ,@(results))
+ (:generator ,(+ 50 num-args num-results)
+ (let ((lra-label (gen-label))
+ (cur-nfp (current-nfp-tn vop)))
+ ,@(moves (arg-names) (temp-names))
+ (inst li (fixnumize ,num-args) nargs)
+ (inst ldw (static-fun-offset symbol) null-tn lip)
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (inst move cfp-tn old-fp)
+ (inst compute-lra-from-code code-tn lra-label temp lra)
+ (note-this-location vop :call-site)
+ (inst bv lip)
+ (inst move csp-tn cfp-tn)
+ (emit-return-pc lra-label)
+ ,(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 move-temp temp lra-label)))
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))
+ ,@(moves (temp-names) (result-names))))))))
) ; EVAL-WHEN
(macrolet
((foo ()
(collect ((templates (list 'progn)))
- (dotimes (i register-arg-count)
- (templates (static-fun-template-vop i 1)))
- (templates))))
+ (dotimes (i register-arg-count)
+ (templates (static-fun-template-vop i 1)))
+ (templates))))
(foo))
(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)))))
(:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
(:temporary (:scs (non-descriptor-reg) :type random) temp)
(:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
- count)
+ count)
(:results (result :scs (any-reg descriptor-reg)))
(:policy :fast-safe)
(:vop-var vop)
FUNCTION-PTR
(load-type result object (- fun-pointer-lowtag))
(inst nop :tr)
-
+
OTHER-PTR
(load-type result object (- other-pointer-lowtag))
-
+
DONE))
(define-vop (fun-subtype)
(:translate (setf fun-subtype))
(:policy :fast-safe)
(:args (type :scs (unsigned-reg) :target result)
- (function :scs (descriptor-reg)))
+ (function :scs (descriptor-reg)))
(:arg-types positive-fixnum *)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:translate set-header-data)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg) :target res)
- (data :scs (unsigned-reg)))
+ (data :scs (unsigned-reg)))
(:arg-types * positive-fixnum)
(:results (res :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(define-vop (make-other-immediate-type)
(:args (val :scs (any-reg descriptor-reg))
- (type :scs (any-reg descriptor-reg) :target temp))
+ (type :scs (any-reg descriptor-reg) :target temp))
(:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 2
(define-vop (compute-fun)
(:args (code :scs (descriptor-reg))
- (offset :scs (signed-reg unsigned-reg)))
+ (offset :scs (signed-reg unsigned-reg)))
(:arg-types * positive-fixnum)
(:results (func :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (non-descriptor-reg)) count)
(:generator 1
(let ((offset
- (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
+ (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
(inst ldw offset count-vector count)
(inst addi 1 count count)
(inst stw count offset count-vector))))
(inst extru value 31 2 zero-tn :<>)
(inst b (if not-p drop-through target) :nullify t))
(%test-headers value target not-p nil headers
- :drop-through drop-through :temp temp)))
+ :drop-through drop-through :temp temp)))
(defun %test-immediate (value target not-p immediate &key temp)
(assemble ()
(inst bci := not-p immediate temp target)))
(defun %test-lowtag (value target not-p lowtag
- &key temp temp-loaded)
+ &key temp temp-loaded)
(assemble ()
(unless temp-loaded
(inst extru value 31 3 temp))
(inst bci := not-p lowtag temp target)))
(defun %test-headers (value target not-p function-p headers
- &key temp (drop-through (gen-label)) temp-loaded)
+ &key temp (drop-through (gen-label)) temp-loaded)
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind
- (equal greater-or-equal when-true when-false)
- ;; 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 :<> :< drop-through target)
- (values := :>= target drop-through))
+ (equal greater-or-equal when-true when-false)
+ ;; 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 :<> :< drop-through target)
+ (values := :>= target drop-through))
(assemble ()
- (%test-lowtag value when-false t lowtag
- :temp temp :temp-loaded temp-loaded)
- (inst ldb (- 3 lowtag) value temp)
- (do ((remaining headers (cdr remaining)))
- ((null remaining))
- (let ((header (car remaining))
- (last (null (cdr remaining))))
- (cond
- ((atom header)
- (if last
- (inst bci equal nil header temp target)
- (inst bci := nil header temp when-true)))
- (t
- (let ((start (car header))
- (end (cdr header)))
- (unless (= start bignum-widetag)
- (inst bci :> nil start temp when-false))
- (if last
- (inst bci greater-or-equal nil end temp target)
- (inst bci :>= nil end temp when-true)))))))
- (emit-label drop-through)))))
+ (%test-lowtag value when-false t lowtag
+ :temp temp :temp-loaded temp-loaded)
+ (inst ldb (- 3 lowtag) value temp)
+ (do ((remaining headers (cdr remaining)))
+ ((null remaining))
+ (let ((header (car remaining))
+ (last (null (cdr remaining))))
+ (cond
+ ((atom header)
+ (if last
+ (inst bci equal nil header temp target)
+ (inst bci := nil header temp when-true)))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ (unless (= start bignum-widetag)
+ (inst bci :> nil start temp when-false))
+ (if last
+ (inst bci greater-or-equal nil end temp target)
+ (inst bci :>= nil end temp when-true)))))))
+ (emit-label drop-through)))))
\f
;;;; Type checking and testing:
(if (> (apply #'max type-codes) lowtag-limit) 7 2)))
(defmacro !define-type-vops (pred-name check-name ptype error-code
- (&rest type-codes)
- &key &allow-other-keys)
+ (&rest type-codes)
+ &key &allow-other-keys)
(let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
`(progn
,@(when pred-name
- `((define-vop (,pred-name type-predicate)
- (:translate ,pred-name)
- (:generator ,cost
- (test-type value target not-p (,@type-codes) :temp temp)))))
+ `((define-vop (,pred-name type-predicate)
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value target not-p (,@type-codes) :temp temp)))))
,@(when check-name
- `((define-vop (,check-name check-type)
- (:generator ,cost
- (let ((err-lab
- (generate-error-code vop ,error-code value)))
- (test-type value err-lab t (,@type-codes) :temp temp)
- (move value result))))))
+ `((define-vop (,check-name check-type)
+ (:generator ,cost
+ (let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value err-lab t (,@type-codes) :temp temp)
+ (move value result))))))
,@(when ptype
- `((primitive-type-vop ,check-name (:check) ,ptype))))))
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
\f
;;;; Other integer ranges.
(multiple-value-bind
(yep nope)
(if not-p
- (values not-target target)
- (values target not-target))
+ (values not-target target)
+ (values target not-target))
(assemble ()
(inst extru value 31 2 zero-tn :<>)
(inst b yep :nullify t)
(define-vop (check-signed-byte-32 check-type)
(:generator 45
(let ((loose (generate-error-code vop object-not-signed-byte-32-error
- value)))
+ value)))
(signed-byte-32-test value temp t loose okay))
OKAY
(move value result)))
;; All zeros, its an (unsigned-byte 32).
(inst comb (if not-p := :<>) temp zero-tn not-target :nullify t)
(inst b target :nullify t)
-
+
SINGLE-WORD
;; Get the single digit.
(loadw temp value bignum-digits-offset other-pointer-lowtag)
(define-vop (check-unsigned-byte-32 check-type)
(:generator 45
(let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
- value)))
+ value)))
(unsigned-byte-32-test value temp t loose okay))
OKAY
(move value result)))
\f
;;;; List/symbol types:
-;;;
+;;;
;;; symbolp (or symbol (eq nil))
;;; consp (and list (not (eq nil)))
(test-type value error t (symbol-header-widetag) :temp temp))
DROP-THRU
(move value result)))
-
+
(define-vop (consp type-predicate)
(:translate consp)
(:generator 8
(:args
(vals :more t))
(:results (start :scs (any-reg) :from :load)
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:info nvals)
(:temporary (:scs (descriptor-reg)) temp)
(:generator 20
(move csp-tn start)
(inst addi (* nvals n-word-bytes) csp-tn csp-tn)
(do ((val vals (tn-ref-across val))
- (i 0 (1+ i)))
- ((null val))
+ (i 0 (1+ i)))
+ ((null val))
(let ((tn (tn-ref-tn val)))
- (sc-case tn
- (descriptor-reg
- (storew tn start i))
- (control-stack
- (load-stack-tn temp tn)
- (storew temp start i)))))
+ (sc-case tn
+ (descriptor-reg
+ (storew tn start i))
+ (control-stack
+ (load-stack-tn temp tn)
+ (storew temp start i)))))
(inst li (fixnumize nvals) count)))
(:arg-types list)
(:policy :fast-safe)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (non-descriptor-reg) :type random) ndescr)
;;;
(define-vop (%more-arg-values)
(:args (context :scs (descriptor-reg any-reg) :target src)
- (skip :scs (any-reg zero immediate))
- (num :scs (any-reg) :target count))
+ (skip :scs (any-reg zero immediate))
+ (num :scs (any-reg) :target count))
(:temporary (:sc any-reg :from (:argument 0)) src)
(:temporary (:sc any-reg :from (:argument 1)) dst end)
(:temporary (:sc descriptor-reg :from (:argument 1)) temp)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:generator 20
(sc-case skip
(zero
;;; FIXME: These want to turn into macrolets.
(macrolet ((defreg (name offset)
- (let ((offset-sym (symbolicate name "-OFFSET")))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (def!constant ,offset-sym ,offset)
- (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
- (defregset (name &rest regs)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter ,name
- (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))))
+ (let ((offset-sym (symbolicate name "-OFFSET")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def!constant ,offset-sym ,offset)
+ (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
+ (defregset (name &rest regs)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter ,name
+ (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))))
;; Wired-zero
(defreg zero 0)
;;;
;;; Handy macro so we don't have to keep changing all the numbers whenever
;;; we insert a new storage class.
-;;;
+;;;
(defmacro !define-storage-classes (&rest classes)
(do ((forms (list 'progn)
- (let* ((class (car classes))
- (sc-name (car class))
- (constant-name (intern (concatenate 'simple-string
- (string sc-name)
- "-SC-NUMBER"))))
- (list* `(define-storage-class ,sc-name ,index
- ,@(cdr class))
- `(defconstant ,constant-name ,index)
- `(export ',constant-name)
- forms)))
+ (let* ((class (car classes))
+ (sc-name (car class))
+ (constant-name (intern (concatenate 'simple-string
+ (string sc-name)
+ "-SC-NUMBER"))))
+ (list* `(define-storage-class ,sc-name ,index
+ ,@(cdr class))
+ `(defconstant ,constant-name ,index)
+ `(export ',constant-name)
+ forms)))
(index 0 (1+ index))
(classes classes (cdr classes)))
((null classes)
(sap-stack non-descriptor-stack) ; System area pointers.
(single-stack non-descriptor-stack) ; single-floats
(double-stack non-descriptor-stack
- :element-size 2 :alignment 2) ; double floats.
+ :element-size 2 :alignment 2) ; double floats.
(complex-single-stack non-descriptor-stack :element-size 2)
(complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
;;;; Make some random tns for important registers.
(macrolet ((defregtn (name sc)
- (let ((offset-sym (symbolicate name "-OFFSET"))
- (tn-sym (symbolicate name "-TN")))
- `(defparameter ,tn-sym
- (make-random-tn :kind :normal
- :sc (sc-or-lose ',sc)
- :offset ,offset-sym)))))
+ (let ((offset-sym (symbolicate name "-OFFSET"))
+ (tn-sym (symbolicate name "-TN")))
+ `(defparameter ,tn-sym
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose ',sc)
+ :offset ,offset-sym)))))
;; These, we access by foo-TN only
-
+
(defregtn zero any-reg)
(defregtn null descriptor-reg)
(defregtn code descriptor-reg)
(defregtn csp any-reg)
(defregtn cfp any-reg)
(defregtn nsp any-reg)
-
+
;; These alias regular locations, so we have to make sure we don't bypass
;; the register allocator when using them.
(defregtn nargs any-reg)
;; And some floating point values.
(defparameter fp-single-zero-tn
(make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset 0))
+ :sc (sc-or-lose 'single-reg)
+ :offset 0))
(defparameter fp-double-zero-tn
(make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset 0))
+ :sc (sc-or-lose 'double-reg)
+ :offset 0))
\f
;;; If VALUE can be represented as an immediate constant, then return
(null
(sc-number-or-lose 'null))
((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
- system-area-pointer character)
+ system-area-pointer character)
(sc-number-or-lose 'immediate))
(symbol
(if (static-symbol-p value)
- (sc-number-or-lose 'immediate)
- nil))
+ (sc-number-or-lose 'immediate)
+ nil))
(single-float
(if (zerop value)
- (sc-number-or-lose 'fp-single-zero)
- nil))
+ (sc-number-or-lose 'fp-single-zero)
+ nil))
(double-float
(if (zerop value)
- (sc-number-or-lose 'fp-double-zero)
- nil))))
+ (sc-number-or-lose 'fp-double-zero)
+ nil))))
\f
;;;; Function Call Parameters
(defconstant register-arg-count 6)
;;; Names to use for the argument registers.
-;;;
+;;;
(defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
) ; EVAL-WHEN
;;;
(defparameter register-arg-tns
(mapcar #'(lambda (n)
- (make-random-tn :kind :normal
- :sc (sc-or-lose 'descriptor-reg)
- :offset n))
- *register-arg-offsets*))
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset n))
+ *register-arg-offsets*))
;;; This is used by the debugger.
(defconstant single-value-return-byte-offset 4)
(!def-vm-support-routine location-print-name (tn)
(declare (type tn tn))
(let ((sb (sb-name (sc-sb (tn-sc tn))))
- (offset (tn-offset tn)))
+ (offset (tn-offset tn)))
(ecase sb
(registers (or (svref *register-names* offset)
- (format nil "R~D" offset)))
+ (format nil "R~D" offset)))
(float-registers (format nil "F~D" offset))
(control-stack (format nil "CS~D" offset))
(non-descriptor-stack (format nil "NS~D" offset))
(:temporary (:scs (descriptor-reg) :type list) ptr)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
- res)
+ res)
(:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
(:info num)
(:results (result :scs (descriptor-reg)))
(:policy :safe)
(:generator 0
(cond ((zerop num)
- (move result null-tn))
- ((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)
- (zero zero-tn)
- (null null-tn)
- (control-stack
- (load-stack-tn temp ,tn)
- temp))))
- (storew reg ,list ,slot list-pointer-lowtag))))
- (let ((cons-cells (if star (1- num) num)))
- (pseudo-atomic (pa-flag
- :extra (* (pad-data-block cons-size)
- cons-cells))
- (inst or res alloc-tn 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 addu ptr 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 null-tn ptr
- cons-cdr-slot list-pointer-lowtag)))
- (aver (null (tn-ref-across things)))
- (move result res))))))))
+ (move result null-tn))
+ ((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)
+ (zero zero-tn)
+ (null null-tn)
+ (control-stack
+ (load-stack-tn temp ,tn)
+ temp))))
+ (storew reg ,list ,slot list-pointer-lowtag))))
+ (let ((cons-cells (if star (1- num) num)))
+ (pseudo-atomic (pa-flag
+ :extra (* (pad-data-block cons-size)
+ cons-cells))
+ (inst or res alloc-tn 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 addu ptr 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 null-tn 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))
- (unboxed-arg :scs (any-reg)))
+ (unboxed-arg :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed)
(:generator 100
(inst li ndescr (lognot lowtag-mask))
(inst addu boxed boxed-arg
- (fixnumize (1+ code-trace-table-offset-slot)))
+ (fixnumize (1+ code-trace-table-offset-slot)))
(inst and boxed ndescr)
(inst srl unboxed unboxed-arg word-shift)
(inst addu unboxed unboxed lowtag-mask)
(inst and unboxed ndescr)
(inst sll ndescr boxed (- n-widetag-bits word-shift))
(inst or ndescr code-header-widetag)
-
+
(pseudo-atomic (pa-flag)
(inst or result alloc-tn other-pointer-lowtag)
(storew ndescr result 0 other-pointer-lowtag)
(let ((size (+ length closure-info-offset)))
(inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
(pseudo-atomic (pa-flag :extra (pad-data-block size))
- (inst or result alloc-tn fun-pointer-lowtag)
- (storew temp result 0 fun-pointer-lowtag))
+ (inst or result alloc-tn fun-pointer-lowtag)
+ (storew temp result 0 fun-pointer-lowtag))
(storew function result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
-;;;
+;;;
(define-vop (make-value-cell)
(:args (value :to :save :scs (descriptor-reg any-reg null zero)))
(:temporary (:scs (non-descriptor-reg)) temp)
(pseudo-atomic (pa-flag :extra (pad-data-block words))
(inst or result alloc-tn lowtag)
(when type
- (inst li temp (logior (ash (1- words) n-widetag-bits) type))
- (storew temp result 0 lowtag)))))
+ (inst li temp (logior (ash (1- words) n-widetag-bits) type))
+ (storew temp result 0 lowtag)))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
(define-vop (fast-lognot/fixnum fixnum-unop)
(:temporary (:scs (any-reg) :type fixnum :to (:result 0))
- temp)
+ temp)
(:translate lognot)
(:generator 2
(inst li temp (fixnumize -1))
(define-vop (fast-fixnum-binop)
(:args (x :target r :scs (any-reg))
- (y :target r :scs (any-reg)))
+ (y :target r :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(define-vop (fast-unsigned-binop)
(:args (x :target r :scs (unsigned-reg))
- (y :target r :scs (unsigned-reg)))
+ (y :target r :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(define-vop (fast-signed-binop)
(:args (x :target r :scs (signed-reg))
- (y :target r :scs (signed-reg)))
+ (y :target r :scs (signed-reg)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:arg-types tagged-num (:constant integer)))
(defmacro define-binop (translate cost untagged-cost op
- tagged-type untagged-type)
+ tagged-type untagged-type)
`(progn
(define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
- fast-fixnum-binop)
+ fast-fixnum-binop)
(:args (x :target r :scs (any-reg))
- (y :target r :scs (any-reg)))
+ (y :target r :scs (any-reg)))
(:translate ,translate)
(:generator ,(1+ cost)
- (inst ,op r x y)))
+ (inst ,op r x y)))
(define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
- fast-signed-binop)
+ fast-signed-binop)
(:args (x :target r :scs (signed-reg))
- (y :target r :scs (signed-reg)))
+ (y :target r :scs (signed-reg)))
(:translate ,translate)
(:generator ,(1+ untagged-cost)
- (inst ,op r x y)))
+ (inst ,op r x y)))
(define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
- fast-unsigned-binop)
+ fast-unsigned-binop)
(:args (x :target r :scs (unsigned-reg))
- (y :target r :scs (unsigned-reg)))
+ (y :target r :scs (unsigned-reg)))
(:translate ,translate)
(:generator ,(1+ untagged-cost)
- (inst ,op r x y)))
+ (inst ,op r x y)))
,@(when tagged-type
- `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
- fast-fixnum-c-binop)
- (:arg-types tagged-num (:constant ,tagged-type))
- (:translate ,translate)
- (:generator ,cost
- (inst ,op r x (fixnumize y))))))
+ `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
+ fast-fixnum-c-binop)
+ (:arg-types tagged-num (:constant ,tagged-type))
+ (:translate ,translate)
+ (:generator ,cost
+ (inst ,op r x (fixnumize y))))))
,@(when untagged-type
- `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
- fast-signed-c-binop)
- (:arg-types signed-num (:constant ,untagged-type))
- (:translate ,translate)
- (:generator ,untagged-cost
- (inst ,op r x y)))
- (define-vop (,(symbolicate "FAST-" translate
- "-C/UNSIGNED=>UNSIGNED")
- fast-unsigned-c-binop)
- (:arg-types unsigned-num (:constant ,untagged-type))
- (:translate ,translate)
- (:generator ,untagged-cost
- (inst ,op r x y)))))))
+ `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
+ fast-signed-c-binop)
+ (:arg-types signed-num (:constant ,untagged-type))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ (inst ,op r x y)))
+ (define-vop (,(symbolicate "FAST-" translate
+ "-C/UNSIGNED=>UNSIGNED")
+ fast-unsigned-c-binop)
+ (:arg-types unsigned-num (:constant ,untagged-type))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ (inst ,op r x y)))))))
(define-binop + 1 5 addu (signed-byte 14) (signed-byte 16))
(define-binop - 1 5 subu
(define-vop (fast-lognor/fixnum=>fixnum fast-fixnum-binop)
(:translate lognor)
(:args (x :target r :scs (any-reg))
- (y :target r :scs (any-reg)))
+ (y :target r :scs (any-reg)))
(:temporary (:sc non-descriptor-reg) temp)
(:generator 4
(inst nor temp x y)
(define-vop (fast-lognor/signed=>signed fast-signed-binop)
(:translate lognor)
(:args (x :target r :scs (signed-reg))
- (y :target r :scs (signed-reg)))
+ (y :target r :scs (signed-reg)))
(:generator 4
(inst nor r x y)))
(define-vop (fast-lognor/unsigned=>unsigned fast-unsigned-binop)
(:translate lognor)
(:args (x :target r :scs (unsigned-reg))
- (y :target r :scs (unsigned-reg)))
+ (y :target r :scs (unsigned-reg)))
(:generator 4
(inst nor r x y)))
(:result-types (:or signed-num unsigned-num))
(:note nil)
(:generator 4
- (inst add r x y)))
+ (inst add r x y)))
(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
(:results (r :scs (any-reg descriptor-reg)))
(:result-types (:or signed-num unsigned-num))
(:note nil)
(:generator 3
- (inst add r x (fixnumize y))))
+ (inst add r x (fixnumize y))))
(define-vop (fast--/fixnum fast--/fixnum=>fixnum)
(:results (r :scs (any-reg descriptor-reg)))
(:result-types (:or signed-num unsigned-num))
(:note nil)
(:generator 4
- (inst sub r x y)))
+ (inst sub r x y)))
(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
(:results (r :scs (any-reg descriptor-reg)))
(:result-types (:or signed-num unsigned-num))
(:note nil)
(:generator 3
- (inst sub r x (fixnumize y))))
+ (inst sub r x (fixnumize y))))
) ; bogus trap-to-c-land +/-
;;; Shifting
(define-vop (fast-ash/unsigned=>unsigned)
(:note "inline ASH")
(:args (number :scs (unsigned-reg) :to :save)
- (amount :scs (signed-reg) :to :save))
+ (amount :scs (signed-reg) :to :save))
(:arg-types unsigned-num signed-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(define-vop (fast-ash/signed=>signed)
(:note "inline ASH")
(:args (number :scs (signed-reg) :to :save)
- (amount :scs (signed-reg)))
+ (amount :scs (signed-reg)))
(:arg-types signed-num signed-num)
(:results (result :scs (signed-reg)))
(:result-types signed-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 1
- (cond
+ (cond
((< count -31) (move result zero-tn))
((< count 0) (inst srl result number (min (- count) 31)))
((> count 0) (inst sll result number (min count 31)))
(:results (result :scs (signed-reg)))
(:result-types signed-num)
(:generator 1
- (cond
+ (cond
((< count 0) (inst sra result number (min (- count) 31)))
((> count 0) (inst sll result number (min count 31)))
(t (bug "identity ASH not transformed away")))))
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
(:generator 30
(let ((loop (gen-label))
- (test (gen-label)))
+ (test (gen-label)))
(move shift arg)
(inst bgez shift test)
(move res zero-tn t)
(emit-label loop)
(inst add res (fixnumize 1))
-
+
(emit-label test)
(inst bne shift loop)
(inst srl shift 1))))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
- :target res) num)
+ :target res) num)
(:temporary (:scs (non-descriptor-reg)) mask temp)
(:generator 30
(inst li mask #x55555555)
(define-vop (fast-truncate/fixnum fast-fixnum-binop)
(:translate truncate)
(:results (q :scs (any-reg))
- (r :scs (any-reg)))
+ (r :scs (any-reg)))
(:result-types tagged-num tagged-num)
(:temporary (:scs (non-descriptor-reg) :to :eval) temp)
(:vop-var vop)
(define-vop (fast-truncate/unsigned fast-unsigned-binop)
(:translate truncate)
(:results (q :scs (unsigned-reg))
- (r :scs (unsigned-reg)))
+ (r :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:vop-var vop)
(:save-p :compute-only)
(define-vop (fast-truncate/signed fast-signed-binop)
(:translate truncate)
(:results (q :scs (signed-reg))
- (r :scs (signed-reg)))
+ (r :scs (signed-reg)))
(:result-types signed-num signed-num)
(:vop-var vop)
(:save-p :compute-only)
(define-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg))
- (y :scs (any-reg)))
+ (y :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison"))
(define-vop (fast-conditional/signed fast-conditional)
(:args (x :scs (signed-reg))
- (y :scs (signed-reg)))
+ (y :scs (signed-reg)))
(:arg-types signed-num signed-num)
(:note "inline (signed-byte 32) comparison"))
(define-vop (fast-conditional/unsigned fast-conditional)
(:args (x :scs (unsigned-reg))
- (y :scs (unsigned-reg)))
+ (y :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 32) comparison"))
(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
(:args (x :scs (unsigned-reg)))
(:arg-types unsigned-num (:constant (and (signed-byte-with-a-bite-out 16 1)
- unsigned-byte)))
+ unsigned-byte)))
(:info target not-p y))
(defmacro define-conditional-vop (translate &rest generator)
`(progn
,@(mapcar #'(lambda (suffix cost signed)
- (unless (and (member suffix '(/fixnum -c/fixnum))
- (eq translate 'eql))
- `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
- translate suffix))
- ,(intern
- (format nil "~:@(FAST-CONDITIONAL~A~)"
- suffix)))
- (:translate ,translate)
- (:generator ,cost
- (let* ((signed ,signed)
- (-c/fixnum ,(eq suffix '-c/fixnum))
- (y (if -c/fixnum (fixnumize y) y)))
- (declare (ignorable signed -c/fixnum y))
- ,@generator)))))
- '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
- '(3 2 5 4 5 4)
- '(t t t t nil nil))))
+ (unless (and (member suffix '(/fixnum -c/fixnum))
+ (eq translate 'eql))
+ `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ translate suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,translate)
+ (:generator ,cost
+ (let* ((signed ,signed)
+ (-c/fixnum ,(eq suffix '-c/fixnum))
+ (y (if -c/fixnum (fixnumize y) y)))
+ (declare (ignorable signed -c/fixnum y))
+ ,@generator)))))
+ '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+ '(3 2 5 4 5 4)
+ '(t t t t nil nil))))
(define-conditional-vop <
(cond ((and signed (eql y 0))
- (if not-p
- (inst bgez x target)
- (inst bltz x target)))
- (t
- (if signed
- (inst slt temp x y)
- (inst sltu temp x y))
- (if not-p
- (inst beq temp zero-tn target)
- (inst bne temp zero-tn target))))
+ (if not-p
+ (inst bgez x target)
+ (inst bltz x target)))
+ (t
+ (if signed
+ (inst slt temp x y)
+ (inst sltu temp x y))
+ (if not-p
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn target))))
(inst nop))
(define-conditional-vop >
(cond ((and signed (eql y 0))
- (if not-p
- (inst blez x target)
- (inst bgtz x target)))
- ((integerp y)
- (let ((y (+ y (if -c/fixnum (fixnumize 1) 1))))
- (if signed
- (inst slt temp x y)
- (inst sltu temp x y))
- (if not-p
- (inst bne temp zero-tn target)
- (inst beq temp zero-tn target))))
- (t
- (if signed
- (inst slt temp y x)
- (inst sltu temp y x))
- (if not-p
- (inst beq temp zero-tn target)
- (inst bne temp zero-tn target))))
+ (if not-p
+ (inst blez x target)
+ (inst bgtz x target)))
+ ((integerp y)
+ (let ((y (+ y (if -c/fixnum (fixnumize 1) 1))))
+ (if signed
+ (inst slt temp x y)
+ (inst sltu temp x y))
+ (if not-p
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))))
+ (t
+ (if signed
+ (inst slt temp y x)
+ (inst sltu temp y x))
+ (if not-p
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn target))))
(inst nop))
;;; 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))
- (y :scs (any-reg)))
+ (y :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison")
(:translate eql)
(:ignore temp)
(:generator 3
(if not-p
- (inst bne x y target)
- (inst beq x y target))
+ (inst bne x y target)
+ (inst beq x y target))
(inst nop)))
;;;
(define-vop (generic-eql/fixnum fast-eql/fixnum)
(:args (x :scs (any-reg descriptor-reg))
- (y :scs (any-reg)))
+ (y :scs (any-reg)))
(:arg-types * tagged-num)
(:variant-cost 7))
(:translate eql)
(:generator 2
(let ((y (cond ((eql y 0) zero-tn)
- (t
- (inst li temp (fixnumize y))
- temp))))
+ (t
+ (inst li temp (fixnumize y))
+ temp))))
(if not-p
- (inst bne x y target)
- (inst beq x y target))
+ (inst bne x y target)
+ (inst beq x y target))
(inst nop))))
;;;
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
(:args (x :scs (any-reg descriptor-reg)))
(:arg-types * (:constant (signed-byte 14)))
(:variant-cost 6))
-
+
\f
;;;; 32-bit logical operations
(define-vop (merge-bits)
(:translate merge-bits)
(:args (shift :scs (signed-reg unsigned-reg))
- (prev :scs (unsigned-reg))
- (next :scs (unsigned-reg)))
+ (prev :scs (unsigned-reg))
+ (next :scs (unsigned-reg)))
(:arg-types tagged-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
(define-vop (shift-towards-someplace)
(:policy :fast-safe)
(:args (num :scs (unsigned-reg))
- (amount :scs (signed-reg)))
+ (amount :scs (signed-reg)))
(:arg-types unsigned-num tagged-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num))
(:translate --mod32))
(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
- fast-ash-c/unsigned=>unsigned)
+ fast-ash-c/unsigned=>unsigned)
(:translate ash-left-mod32))
(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 lognor-mod32 (x y) lognor :unsigned 32)
(define-vop (fast-lognor-mod32/unsigned=>unsigned
- fast-lognor/unsigned=>unsigned)
+ fast-lognor/unsigned=>unsigned)
(:translate lognor-mod32))
(define-source-transform logeqv (&rest args)
(:info target not-p)
(:generator 2
(if not-p
- (inst bltz digit target)
- (inst bgez digit target))
+ (inst bltz digit target)
+ (inst bgez digit target))
(inst nop)))
(define-vop (add-w/carry)
(:translate sb!bignum:%add-with-carry)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
- (b :scs (unsigned-reg))
- (c :scs (any-reg)))
+ (b :scs (unsigned-reg))
+ (c :scs (any-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
(:results (result :scs (unsigned-reg))
- (carry :scs (unsigned-reg) :from :eval))
+ (carry :scs (unsigned-reg) :from :eval))
(:result-types unsigned-num positive-fixnum)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 5
(let ((carry-in (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst bne c carry-in)
(inst addu res a b)
(:translate sb!bignum:%subtract-with-borrow)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
- (b :scs (unsigned-reg))
- (c :scs (any-reg)))
+ (b :scs (unsigned-reg))
+ (c :scs (any-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
(:results (result :scs (unsigned-reg))
- (borrow :scs (unsigned-reg) :from :eval))
+ (borrow :scs (unsigned-reg) :from :eval))
(:result-types unsigned-num positive-fixnum)
(:generator 4
(let ((no-borrow-in (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst bne c no-borrow-in)
(inst subu res a b)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg))
- (y :scs (unsigned-reg))
- (carry-in :scs (unsigned-reg) :to :save))
+ (y :scs (unsigned-reg))
+ (carry-in :scs (unsigned-reg) :to :save))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :from (:argument 1)) temp)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 6
(inst multu x y)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg))
- (y :scs (unsigned-reg))
- (prev :scs (unsigned-reg))
- (carry-in :scs (unsigned-reg) :to :save))
+ (y :scs (unsigned-reg))
+ (prev :scs (unsigned-reg))
+ (carry-in :scs (unsigned-reg) :to :save))
(:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :from (:argument 2)) temp)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 9
(inst multu x y)
(:translate sb!bignum:%multiply)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg))
- (y :scs (unsigned-reg)))
+ (y :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 3
(inst multu x y)
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (num-high :scs (unsigned-reg) :target rem)
- (num-low :scs (unsigned-reg) :target rem-low)
- (denom :scs (unsigned-reg) :to (:eval 1)))
+ (num-low :scs (unsigned-reg) :target rem-low)
+ (denom :scs (unsigned-reg) :to (:eval 1)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low)
(:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
(:results (quo :scs (unsigned-reg) :from (:eval 0))
- (rem :scs (unsigned-reg) :from (:argument 0)))
+ (rem :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num unsigned-num)
(:generator 325 ; number of inst assuming targeting works.
(move rem num-high)
(move rem-low num-low)
(flet ((maybe-subtract (&optional (guess temp))
- (inst subu temp guess 1)
- (inst and temp denom)
- (inst subu rem temp)))
+ (inst subu temp guess 1)
+ (inst and temp denom)
+ (inst subu rem temp)))
(inst sltu quo rem denom)
(maybe-subtract quo)
(dotimes (i 32)
- (inst sll rem 1)
- (inst srl temp rem-low 31)
- (inst or rem temp)
- (inst sll rem-low 1)
- (inst sltu temp rem denom)
- (inst sll quo 1)
- (inst or quo temp)
- (maybe-subtract)))
+ (inst sll rem 1)
+ (inst srl temp rem-low 31)
+ (inst or rem temp)
+ (inst sll rem-low 1)
+ (inst sltu temp rem denom)
+ (inst sll quo 1)
+ (inst or quo temp)
+ (maybe-subtract)))
(inst nor quo zero-tn)))
(define-vop (signify-digit)
(:translate sb!bignum:%ashr)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg))
- (count :scs (unsigned-reg)))
+ (count :scs (unsigned-reg)))
(:arg-types unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(define-static-fun two-arg-gcd (x y) :translate gcd)
(define-static-fun two-arg-lcm (x y) :translate lcm)
-
+
(define-static-fun two-arg-+ (x y) :translate +)
(define-static-fun two-arg-- (x y) :translate -)
(define-static-fun two-arg-* (x y) :translate *)
(define-static-fun two-arg-/ (x y) :translate /)
-
+
(define-static-fun two-arg-< (x y) :translate <)
(define-static-fun two-arg-<= (x y) :translate <=)
(define-static-fun two-arg-> (x y) :translate >)
(define-static-fun two-arg->= (x y) :translate >=)
(define-static-fun two-arg-= (x y) :translate =)
(define-static-fun two-arg-/= (x y) :translate /=)
-
+
(define-static-fun %negate (x) :translate %negate)
(define-static-fun two-arg-and (x y) :translate logand)
(:policy :fast-safe)
(:translate make-array-header)
(:args (type :scs (any-reg))
- (rank :scs (any-reg)))
+ (rank :scs (any-reg)))
(:arg-types positive-fixnum positive-fixnum)
(:temporary (:scs (any-reg)) bytes)
(:temporary (:scs (non-descriptor-reg)) header)
(:results (result :scs (descriptor-reg)))
(:generator 13
(inst addu bytes rank (+ (* array-dimensions-offset n-word-bytes)
- lowtag-mask))
+ lowtag-mask))
(inst li header (lognot lowtag-mask))
(inst and bytes header)
(inst addu header rank (fixnumize (1- array-dimensions-offset)))
(: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))
(:results (result :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(let ((error (generate-error-code vop invalid-array-index-error
- array bound index)))
+ array bound index)))
(inst sltu temp index bound)
(inst beq temp zero-tn error)
(inst nop)
vector-data-offset other-pointer-lowtag ,scs ,element-type
data-vector-set)))
- (def-partial-data-vector-frobs (type element-type size signed &rest scs)
+ (def-partial-data-vector-frobs (type element-type size signed &rest scs)
`(progn
(define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
,size ,signed vector-data-offset other-pointer-lowtag ,scs
(def-full-data-vector-frobs simple-vector *
descriptor-reg any-reg null zero)
-
- (def-partial-data-vector-frobs simple-base-string character
+
+ (def-partial-data-vector-frobs simple-base-string character
:byte nil character-reg)
#!+sb-unicode
(def-full-data-vector-frobs simple-character-string character character-reg)
-
+
(def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
:byte nil unsigned-reg signed-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
;;; 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))))
+ (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 (value :scs (any-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (interior-reg)) lip)
- (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
- (:generator 20
- (inst srl temp index ,bit-shift)
- (inst sll temp 2)
- (inst addu lip object temp)
- (inst lw result lip
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- (inst and temp index ,(1- elements-per-word))
- ,@(when (eq *backend-byte-order* :big-endian)
- `((inst xor temp ,(1- elements-per-word))))
- ,@(unless (= bits 1)
- `((inst sll temp ,(1- (integer-length bits)))))
- (inst srl result temp)
- (inst and result ,(1- (ash 1 bits)))
- (inst sll value result 2)))
+ (: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 (value :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
+ (:generator 20
+ (inst srl temp index ,bit-shift)
+ (inst sll temp 2)
+ (inst addu lip object temp)
+ (inst lw result lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst and temp index ,(1- elements-per-word))
+ ,@(when (eq *backend-byte-order* :big-endian)
+ `((inst xor temp ,(1- elements-per-word))))
+ ,@(unless (= bits 1)
+ `((inst sll temp ,(1- (integer-length bits)))))
+ (inst srl result temp)
+ (inst and result ,(1- (ash 1 bits)))
+ (inst sll value result 2)))
(define-vop (,(symbolicate 'data-vector-ref-c/ type))
- (:translate data-vector-ref)
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:arg-types ,type
- (:constant
- (integer 0
- ,(1- (* (1+ (- (floor (+ #x7fff
- other-pointer-lowtag)
- n-word-bytes)
- vector-data-offset))
- elements-per-word)))))
- (:info index)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:generator 15
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- ,@(when (eq *backend-byte-order* :big-endian)
- `((setf extra (logxor extra (1- ,elements-per-word)))))
- (loadw result object (+ word vector-data-offset)
- other-pointer-lowtag)
- (unless (zerop extra)
- (inst srl 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
+ (integer 0
+ ,(1- (* (1+ (- (floor (+ #x7fff
+ other-pointer-lowtag)
+ n-word-bytes)
+ vector-data-offset))
+ elements-per-word)))))
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 15
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ ,@(when (eq *backend-byte-order* :big-endian)
+ `((setf extra (logxor extra (1- ,elements-per-word)))))
+ (loadw result object (+ word vector-data-offset)
+ other-pointer-lowtag)
+ (unless (zerop extra)
+ (inst srl 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))
- (index :scs (unsigned-reg) :target shift)
- (value :scs (unsigned-reg zero immediate) :target result))
- (:arg-types ,type positive-fixnum positive-fixnum)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (interior-reg)) lip)
- (:temporary (:scs (non-descriptor-reg)) temp old)
- (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
- (:generator 25
- (inst srl temp index ,bit-shift)
- (inst sll temp 2)
- (inst addu lip object temp)
- (inst lw old lip
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- (inst and shift index ,(1- elements-per-word))
- ,@(when (eq *backend-byte-order* :big-endian)
- `((inst xor shift ,(1- elements-per-word))))
- ,@(unless (= bits 1)
- `((inst sll shift ,(1- (integer-length bits)))))
- (unless (and (sc-is value immediate)
- (= (tn-value value) ,(1- (ash 1 bits))))
- (inst li temp ,(1- (ash 1 bits)))
- (inst sll temp shift)
- (inst nor temp temp zero-tn)
- (inst and old temp))
- (unless (sc-is value zero)
- (sc-case value
- (immediate
- (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
- (unsigned-reg
- (inst and temp value ,(1- (ash 1 bits)))))
- (inst sll temp shift)
- (inst or old temp))
- (inst sw old lip
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- (sc-case value
- (immediate
- (inst li result (tn-value value)))
- (zero
- (move result zero-tn))
- (unsigned-reg
- (move result value)))))
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg) :target shift)
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type positive-fixnum positive-fixnum)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:scs (non-descriptor-reg)) temp old)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
+ (:generator 25
+ (inst srl temp index ,bit-shift)
+ (inst sll temp 2)
+ (inst addu lip object temp)
+ (inst lw old lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst and shift index ,(1- elements-per-word))
+ ,@(when (eq *backend-byte-order* :big-endian)
+ `((inst xor shift ,(1- elements-per-word))))
+ ,@(unless (= bits 1)
+ `((inst sll shift ,(1- (integer-length bits)))))
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (inst li temp ,(1- (ash 1 bits)))
+ (inst sll temp shift)
+ (inst nor temp temp zero-tn)
+ (inst and old temp))
+ (unless (sc-is value zero)
+ (sc-case value
+ (immediate
+ (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
+ (unsigned-reg
+ (inst and temp value ,(1- (ash 1 bits)))))
+ (inst sll temp shift)
+ (inst or old temp))
+ (inst sw old lip
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (sc-case value
+ (immediate
+ (inst li result (tn-value value)))
+ (zero
+ (move result zero-tn))
+ (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 zero immediate) :target result))
- (:arg-types ,type
- (:constant
- (integer 0
- ,(1- (* (1+ (- (floor (+ #x7fff
- other-pointer-lowtag)
- n-word-bytes)
- vector-data-offset))
- elements-per-word))))
- positive-fixnum)
- (:info index)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg)) temp old)
- (:generator 20
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- ,@(when (eq *backend-byte-order* :big-endian)
- `((setf extra (logxor extra (1- ,elements-per-word)))))
- (inst lw old object
- (- (* (+ word vector-data-offset) n-word-bytes)
- other-pointer-lowtag))
- (unless (and (sc-is value immediate)
- (= (tn-value value) ,(1- (ash 1 bits))))
- (cond ((= extra ,(1- elements-per-word))
- (inst sll old ,bits)
- (inst srl old ,bits))
- (t
- (inst li temp
- (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
- (inst and old temp))))
- (sc-case value
- (zero)
- (immediate
- (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
- (* extra ,bits))))
- (cond ((< value #x10000)
- (inst or old value))
- (t
- (inst li temp value)
- (inst or old temp)))))
- (unsigned-reg
- (inst sll temp value (* extra ,bits))
- (inst or old temp)))
- (inst sw old object
- (- (* (+ word vector-data-offset) n-word-bytes)
- other-pointer-lowtag))
- (sc-case value
- (immediate
- (inst li result (tn-value value)))
- (zero
- (move result zero-tn))
- (unsigned-reg
- (move result value))))))))))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type
+ (:constant
+ (integer 0
+ ,(1- (* (1+ (- (floor (+ #x7fff
+ other-pointer-lowtag)
+ n-word-bytes)
+ vector-data-offset))
+ elements-per-word))))
+ positive-fixnum)
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) temp old)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ ,@(when (eq *backend-byte-order* :big-endian)
+ `((setf extra (logxor extra (1- ,elements-per-word)))))
+ (inst lw old object
+ (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag))
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (cond ((= extra ,(1- elements-per-word))
+ (inst sll old ,bits)
+ (inst srl old ,bits))
+ (t
+ (inst li temp
+ (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
+ (inst and old temp))))
+ (sc-case value
+ (zero)
+ (immediate
+ (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
+ (* extra ,bits))))
+ (cond ((< value #x10000)
+ (inst or old value))
+ (t
+ (inst li temp value)
+ (inst or old temp)))))
+ (unsigned-reg
+ (inst sll temp value (* extra ,bits))
+ (inst or old temp)))
+ (inst sw old object
+ (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag))
+ (sc-case value
+ (immediate
+ (inst li result (tn-value value)))
+ (zero
+ (move result zero-tn))
+ (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 20
(inst addu lip object index)
(inst lwc1 value lip
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
(inst nop)))
(define-vop (data-vector-set/simple-array-single-float)
(: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 20
(inst addu lip object index)
(inst swc1 value lip
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
(unless (location= result value)
(inst fmove :single 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)
(ecase *backend-byte-order*
(:big-endian
(inst lwc1 value lip
- (+ (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)
- n-word-bytes))
+ (+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ n-word-bytes))
(inst lwc1-odd value lip
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
(:little-endian
(inst lwc1 value lip
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
(inst lwc1-odd value lip
- (+ (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)
- n-word-bytes))))
+ (+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ n-word-bytes))))
(inst nop)))
(define-vop (data-vector-set/simple-array-double-float)
(: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)
(ecase *backend-byte-order*
(:big-endian
(inst swc1 value lip
- (+ (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)
- n-word-bytes))
+ (+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ n-word-bytes))
(inst swc1-odd value lip
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)))
(:little-endian
(inst swc1 value lip
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
(inst swc1-odd value lip
- (+ (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)
- n-word-bytes))))
+ (+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag)
+ n-word-bytes))))
(unless (location= result value)
(inst fmove :double result value))))
\f
(: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)))
(:temporary (:scs (interior-reg)) lip)
(inst addu lip index)
(let ((real-tn (complex-single-reg-real-tn value)))
(inst lwc1 real-tn lip (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(inst lwc1 imag-tn lip (- (* (1+ vector-data-offset) n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(inst nop)))
(define-vop (data-vector-set/simple-array-complex-single-float)
(: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)
(:temporary (:scs (interior-reg)) lip)
(inst addu lip object index)
(inst addu lip 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 swc1 value-real lip (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(unless (location= result-real value-real)
- (inst fmove :single result-real value-real)))
+ (inst fmove :single 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 swc1 value-imag lip (- (* (1+ vector-data-offset) n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(unless (location= result-imag value-imag)
- (inst fmove :single result-imag value-imag)))))
+ (inst fmove :single 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) :target shift))
+ (index :scs (any-reg) :target shift))
(:arg-types simple-array-complex-double-float positive-fixnum)
(:results (value :scs (complex-double-reg)))
(:result-types complex-double-float)
(inst addu lip object shift)
(let ((real-tn (complex-double-reg-real-tn value)))
(ld-double real-tn lip (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(ld-double imag-tn lip (- (* (+ vector-data-offset 2) n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(inst nop)))
(define-vop (data-vector-set/simple-array-complex-double-float)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg) :target shift)
- (value :scs (complex-double-reg) :target result))
+ (index :scs (any-reg) :target shift)
+ (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)
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (any-reg) :from (:argument 1)) shift)
(:generator 6
(inst sll shift index 2)
- (inst addu lip object shift)
+ (inst addu lip object shift)
(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)))
(str-double value-real lip (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(unless (location= result-real value-real)
- (inst fmove :double result-real value-real)))
+ (inst fmove :double 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)))
(str-double value-imag lip (- (* (+ vector-data-offset 2) n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(unless (location= result-imag value-imag)
- (inst fmove :double result-imag value-imag)))))
+ (inst fmove :double result-imag value-imag)))))
\f
;;; These VOPs are used for implementing float slots in structures (whose raw
(:translate %raw-set-double)
(:arg-types sb!c::raw-vector positive-fixnum double-float))
(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-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-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-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))
;;; perhaps?
(def!constant +backend-fasl-file-implementation+ :mips)
(setf *backend-register-save-penalty* 3)
-(setf *backend-byte-order*
- #!+little-endian :little-endian
+(setf *backend-byte-order*
+ #!+little-endian :little-endian
#!-little-endian :big-endian)
;;; FIXME: Check this. Where is it used?
(setf *backend-page-size* 4096)
(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
(stack-frame-size 0)
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(setf (arg-state-did-int-arg state) t)
(multiple-value-bind
- (ptype reg-sc stack-sc)
- (if (alien-integer-type-signed type)
- (values 'signed-byte-32 'signed-reg 'signed-stack)
- (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
+ (ptype reg-sc stack-sc)
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-32 'signed-reg 'signed-stack)
+ (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
(if (< stack-frame-size 4)
- (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4))
- (my-make-wired-tn ptype stack-sc stack-frame-size)))))
+ (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4))
+ (my-make-wired-tn ptype stack-sc stack-frame-size)))))
(define-alien-type-method (system-area-pointer :arg-tn) (type state)
(declare (ignore type))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(setf (arg-state-did-int-arg state) t)
(if (< stack-frame-size 4)
- (my-make-wired-tn 'system-area-pointer
- 'sap-reg
- (+ stack-frame-size 4))
- (my-make-wired-tn 'system-area-pointer
- 'sap-stack
- stack-frame-size))))
+ (my-make-wired-tn 'system-area-pointer
+ 'sap-reg
+ (+ stack-frame-size 4))
+ (my-make-wired-tn 'system-area-pointer
+ 'sap-stack
+ stack-frame-size))))
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
- (float-args (arg-state-float-args state)))
+ (float-args (arg-state-float-args state)))
(setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
(setf (arg-state-float-args state) (1+ float-args))
(cond ((>= stack-frame-size 4)
- (my-make-wired-tn 'double-float
- 'double-stack
- stack-frame-size))
- ((and (not (arg-state-did-int-arg state))
- (< float-args 2))
- (my-make-wired-tn 'double-float
- 'double-reg
- (+ (* float-args 2) 12)))
- (t
+ (my-make-wired-tn 'double-float
+ 'double-stack
+ stack-frame-size))
+ ((and (not (arg-state-did-int-arg state))
+ (< float-args 2))
+ (my-make-wired-tn 'double-float
+ 'double-reg
+ (+ (* float-args 2) 12)))
+ (t
(my-make-wired-tn 'double-float
'double-int-carg-reg
(+ stack-frame-size 4))))))
(define-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state))
- (float-args (arg-state-float-args state)))
+ (float-args (arg-state-float-args state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(setf (arg-state-float-args state) (1+ float-args))
(cond ((>= stack-frame-size 4)
- (my-make-wired-tn 'single-float
- 'single-stack
- stack-frame-size))
- ((and (not (arg-state-did-int-arg state))
- (< float-args 2))
- (my-make-wired-tn 'single-float
- 'single-reg
- (+ (* float-args 2) 12)))
- (t
+ (my-make-wired-tn 'single-float
+ 'single-stack
+ stack-frame-size))
+ ((and (not (arg-state-did-int-arg state))
+ (< float-args 2))
+ (my-make-wired-tn 'single-float
+ 'single-reg
+ (+ (* float-args 2) 12)))
+ (t
(my-make-wired-tn 'single-float
'single-int-carg-reg
(+ stack-frame-size 4))))))
(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)
(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 nsp-offset)
- (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes)
- (arg-tns)
- (invoke-alien-type-method :result-tn
- (alien-fun-type-result-type type)
- (make-result-state))))))
+ (* (max (arg-state-stack-frame-size arg-state) 4) 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))
(aver (sb!c::constant-lvar-p type))
(let* ((type (sb!c::lvar-value type))
- (env (sb!kernel:make-null-lexenv))
- (arg-types (alien-fun-type-arg-types type))
- (result-type (alien-fun-type-result-type type)))
+ (env (sb!kernel:make-null-lexenv))
+ (arg-types (alien-fun-type-arg-types type))
+ (result-type (alien-fun-type-result-type type)))
(aver (= (length arg-types) (length args)))
;; We need to do something special for 64-bit integer arguments
;; and results.
(if (or (some #'(lambda (type)
- (and (alien-integer-type-p type)
- (> (sb!alien::alien-integer-type-bits type) 32)))
- arg-types)
- (and (alien-integer-type-p result-type)
- (> (sb!alien::alien-integer-type-bits result-type) 32)))
- (collect ((new-args) (lambda-vars) (new-arg-types))
- (dolist (type arg-types)
- (let ((arg (gensym)))
- (lambda-vars arg)
- (cond ((and (alien-integer-type-p type)
- (> (sb!alien::alien-integer-type-bits type) 32))
- ;; 64-bit long long types are stored in
- ;; consecutive locations, endian word order,
- ;; aligned to 8 bytes.
- (if (oddp (length (new-args)))
- (new-args nil))
- #!-little-endian
- (progn (new-args `(ash ,arg -32))
- (new-args `(logand ,arg #xffffffff))
- (if (oddp (length (new-arg-types)))
- (new-arg-types (parse-alien-type '(unsigned 32) env)))
- (if (alien-integer-type-signed type)
- (new-arg-types (parse-alien-type '(signed 32) env))
- (new-arg-types (parse-alien-type '(unsigned 32) env)))
- (new-arg-types (parse-alien-type '(unsigned 32) env)))
- #!+little-endian
- (progn (new-args `(logand ,arg #xffffffff))
- (new-args `(ash ,arg -32))
- (if (oddp (length (new-arg-types)))
- (new-arg-types (parse-alien-type '(unsigned 32) env)))
- (new-arg-types (parse-alien-type '(unsigned 32) env))
- (if (alien-integer-type-signed type)
- (new-arg-types (parse-alien-type '(signed 32) env))
- (new-arg-types (parse-alien-type '(unsigned 32) env)))))
- (t
- (new-args arg)
- (new-arg-types type)))))
- (cond ((and (alien-integer-type-p result-type)
- (> (sb!alien::alien-integer-type-bits result-type) 32))
- (let ((new-result-type
- (let ((sb!alien::*values-type-okay* t))
- (parse-alien-type
- (if (alien-integer-type-signed result-type)
- #!-little-endian
- '(values (signed 32) (unsigned 32))
- #!+little-endian
- '(values (unsigned 32) (signed 32))
- '(values (unsigned 32) (unsigned 32)))
- env))))
- `(lambda (function type ,@(lambda-vars))
- (declare (ignore type))
- (multiple-value-bind
- #!-little-endian
- (high low)
- #!+little-endian
- (low high)
- (%alien-funcall function
- ',(make-alien-fun-type
- :arg-types (new-arg-types)
- :result-type new-result-type)
- ,@(new-args))
- (logior low (ash high 32))))))
- (t
- `(lambda (function type ,@(lambda-vars))
- (declare (ignore type))
- (%alien-funcall function
- ',(make-alien-fun-type
- :arg-types (new-arg-types)
- :result-type result-type)
- ,@(new-args))))))
- (sb!c::give-up-ir1-transform))))
+ (and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32)))
+ arg-types)
+ (and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32)))
+ (collect ((new-args) (lambda-vars) (new-arg-types))
+ (dolist (type arg-types)
+ (let ((arg (gensym)))
+ (lambda-vars arg)
+ (cond ((and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32))
+ ;; 64-bit long long types are stored in
+ ;; consecutive locations, endian word order,
+ ;; aligned to 8 bytes.
+ (if (oddp (length (new-args)))
+ (new-args nil))
+ #!-little-endian
+ (progn (new-args `(ash ,arg -32))
+ (new-args `(logand ,arg #xffffffff))
+ (if (oddp (length (new-arg-types)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (if (alien-integer-type-signed type)
+ (new-arg-types (parse-alien-type '(signed 32) env))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ #!+little-endian
+ (progn (new-args `(logand ,arg #xffffffff))
+ (new-args `(ash ,arg -32))
+ (if (oddp (length (new-arg-types)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env))
+ (if (alien-integer-type-signed type)
+ (new-arg-types (parse-alien-type '(signed 32) env))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))))
+ (t
+ (new-args arg)
+ (new-arg-types type)))))
+ (cond ((and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32))
+ (let ((new-result-type
+ (let ((sb!alien::*values-type-okay* t))
+ (parse-alien-type
+ (if (alien-integer-type-signed result-type)
+ #!-little-endian
+ '(values (signed 32) (unsigned 32))
+ #!+little-endian
+ '(values (unsigned 32) (signed 32))
+ '(values (unsigned 32) (unsigned 32)))
+ env))))
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (multiple-value-bind
+ #!-little-endian
+ (high low)
+ #!+little-endian
+ (low high)
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type new-result-type)
+ ,@(new-args))
+ (logior low (ash high 32))))))
+ (t
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type result-type)
+ ,@(new-args))))))
+ (sb!c::give-up-ir1-transform))))
(define-vop (foreign-symbol-sap)
(:translate foreign-symbol-sap)
(define-vop (call-out)
(:args (function :scs (sap-reg) :target cfunc)
- (args :more t))
+ (args :more t))
(:results (results :more t))
(:ignore args results)
(:save-p t)
(:temporary (:sc any-reg :offset cfunc-offset
- :from (:argument 0) :to (:result 0)) cfunc)
+ :from (:argument 0) :to (:result 0)) cfunc)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:vop-var vop)
(:generator 0
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(inst jal (make-fixup "call_into_c" :foreign))
(move cfunc function t)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))))
+ (load-stack-tn cur-nfp nfp-save)))))
(define-vop (alloc-number-stack-space)
(:info amount)
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (cond ((< delta (ash 1 15))
- (inst subu nsp-tn delta))
- (t
- (inst li temp delta)
- (inst subu nsp-tn temp)))))
+ (cond ((< delta (ash 1 15))
+ (inst subu nsp-tn delta))
+ (t
+ (inst li temp delta)
+ (inst subu nsp-tn temp)))))
(move result nsp-tn)))
(define-vop (dealloc-number-stack-space)
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (cond ((< delta (ash 1 15))
- (inst addu nsp-tn delta))
- (t
- (inst li temp delta)
- (inst addu nsp-tn temp)))))))
+ (cond ((< delta (ash 1 15))
+ (inst addu nsp-tn delta))
+ (t
+ (inst li temp delta)
+ (inst addu nsp-tn temp)))))))
(declare (type unsigned-byte n))
(if (< n register-arg-count)
(make-wired-tn *backend-t-primitive-type*
- register-arg-scn
- (elt *register-arg-offsets* n))
+ register-arg-scn
+ (elt *register-arg-offsets* n))
(make-wired-tn *backend-t-primitive-type*
- control-stack-arg-scn n)))
+ control-stack-arg-scn n)))
;;; Make a passing location TN for a local call return PC. If standard is
(specify-save-tn
(physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
(make-wired-tn *fixnum-primitive-type*
- control-stack-arg-scn
- ocfp-save-offset)))
+ control-stack-arg-scn
+ ocfp-save-offset)))
(!def-vm-support-routine make-return-pc-save-location (env)
(let ((ptype *backend-t-primitive-type*))
(specify-save-tn
;;; 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
(declare (type component component))
(dotimes (i code-constants-offset)
(vector-push-extend nil
- (ir2-component-constants (component-info component))))
+ (ir2-component-constants (component-info component))))
(values))
\f
;;; Return the number of bytes needed for the current non-descriptor stack
;;; frame. Non-descriptor stack frames must be multiples of 8 bytes on
;;; the PMAX.
-;;;
+;;;
(defun bytes-needed-for-non-descriptor-stack-frame ()
(* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1)
n-word-bytes))
(:generator 1
(let ((nfp (current-nfp-tn vop)))
(when nfp
- (inst addu val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
+ (inst addu val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
(define-vop (xep-allocate-frame)
)
;; Build our stack frames.
(inst addu csp-tn cfp-tn
- (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
(let ((nfp (current-nfp-tn vop)))
(when nfp
- (inst addu nsp-tn nsp-tn
- (- (bytes-needed-for-non-descriptor-stack-frame)))
- (move nfp nsp-tn)))
+ (inst addu nsp-tn nsp-tn
+ (- (bytes-needed-for-non-descriptor-stack-frame)))
+ (move nfp nsp-tn)))
(trace-table-entry trace-table-normal)))
(define-vop (allocate-frame)
(:results (res :scs (any-reg))
- (nfp :scs (any-reg)))
+ (nfp :scs (any-reg)))
(:info callee)
(:generator 2
(trace-table-entry trace-table-fun-prologue)
(move res csp-tn)
(inst addu csp-tn csp-tn
- (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
(when (ir2-physenv-number-stack-p callee)
(inst addu nsp-tn nsp-tn
- (- (bytes-needed-for-non-descriptor-stack-frame)))
+ (- (bytes-needed-for-non-descriptor-stack-frame)))
(move nfp nsp-tn))
(trace-table-entry trace-table-normal)))
;;;
;;; The general-case code looks like this:
#|
- b regs-defaulted ; Skip if MVs
- nop
+ b regs-defaulted ; Skip if MVs
+ nop
- move a1 null-tn ; Default register values
- ...
- loadi nargs 1 ; Force defaulting of stack values
- move ocfp csp ; Set up args for SP resetting
+ move a1 null-tn ; Default register values
+ ...
+ loadi nargs 1 ; Force defaulting of stack values
+ move ocfp csp ; Set up args for SP resetting
regs-defaulted
- subu temp nargs register-arg-count
+ subu temp nargs register-arg-count
- bltz temp default-value-7 ; jump to default code
+ bltz temp default-value-7 ; jump to default code
addu temp temp -1
- loadw move-temp ocfp-tn 6 ; Move value to correct location.
- store-stack-tn val4-tn move-temp
+ loadw move-temp ocfp-tn 6 ; Move value to correct location.
+ store-stack-tn val4-tn move-temp
- bltz temp default-value-8
+ bltz temp default-value-8
addu temp temp -1
- loadw move-temp ocfp-tn 7
- store-stack-tn val5-tn move-temp
+ loadw move-temp ocfp-tn 7
+ store-stack-tn val5-tn move-temp
- ...
+ ...
defaulting-done
- move sp ocfp ; Reset SP.
+ move sp ocfp ; Reset SP.
<end of code>
<elsewhere>
default-value-7
- store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack)
+ store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack)
default-value-8
- store-stack-tn val5-tn null-tn ; Nil out 8'th value.
+ store-stack-tn val5-tn null-tn ; Nil out 8'th value.
- ...
+ ...
- br defaulting-done
+ br defaulting-done
nop
|#
;;;
(defun default-unknown-values (vop values nvals move-temp temp lra-label)
(declare (type (or tn-ref null) values)
- (type unsigned-byte nvals) (type tn move-temp temp))
+ (type unsigned-byte nvals) (type tn move-temp temp))
(if (<= nvals 1)
(progn
- ;; Note that this is a single-value return point. This is actually
- ;; the multiple-value entry point for a single desired value, but
- ;; the code location has to be here, or the debugger backtrace
- ;; gets confused.
- (without-scheduling ()
- (note-this-location vop :single-value-return)
- (inst move csp-tn ocfp-tn)
- (inst nop))
- (when lra-label
- (inst compute-code-from-lra code-tn code-tn lra-label temp)))
+ ;; Note that this is a single-value return point. This is actually
+ ;; the multiple-value entry point for a single desired value, but
+ ;; the code location has to be here, or the debugger backtrace
+ ;; gets confused.
+ (without-scheduling ()
+ (note-this-location vop :single-value-return)
+ (inst move csp-tn ocfp-tn)
+ (inst nop))
+ (when lra-label
+ (inst compute-code-from-lra code-tn code-tn lra-label temp)))
(let ((regs-defaulted (gen-label))
- (defaulting-done (gen-label))
- (default-stack-vals (gen-label)))
- (without-scheduling ()
- ;; Note that this is an unknown-values return point.
- (note-this-location vop :unknown-return)
- ;; Branch off to the MV case.
- (inst b regs-defaulted)
- ;; If there are no stack results, clear the stack now.
- (if (> nvals register-arg-count)
- (inst addu temp nargs-tn (fixnumize (- register-arg-count)))
- (move csp-tn ocfp-tn t)))
-
- ;; Do the single value calse.
- (do ((i 1 (1+ i))
- (val (tn-ref-across values) (tn-ref-across val)))
- ((= i (min nvals register-arg-count)))
- (move (tn-ref-tn val) null-tn))
- (when (> nvals register-arg-count)
- (inst b default-stack-vals)
- (move ocfp-tn csp-tn t))
-
- (emit-label regs-defaulted)
-
- (when (> nvals register-arg-count)
- ;; If there are stack results, we have to default them
- ;; and clear the stack.
- (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 blez temp default-lab)
- (inst lw move-temp ocfp-tn (* i n-word-bytes))
- (inst addu temp temp (fixnumize -1))
- (store-stack-tn tn move-temp)))
-
- (emit-label defaulting-done)
- (move csp-tn ocfp-tn)
-
- (let ((defaults (defaults)))
- (aver defaults)
- (assemble (*elsewhere*)
- (emit-label default-stack-vals)
- (do ((remaining defaults (cdr remaining)))
- ((null remaining))
- (let ((def (car remaining)))
- (emit-label (car def))
- (when (null (cdr remaining))
- (inst b defaulting-done))
- (store-stack-tn (cdr def) null-tn)))))))
-
- (when lra-label
- (inst compute-code-from-lra code-tn code-tn lra-label temp))))
+ (defaulting-done (gen-label))
+ (default-stack-vals (gen-label)))
+ (without-scheduling ()
+ ;; Note that this is an unknown-values return point.
+ (note-this-location vop :unknown-return)
+ ;; Branch off to the MV case.
+ (inst b regs-defaulted)
+ ;; If there are no stack results, clear the stack now.
+ (if (> nvals register-arg-count)
+ (inst addu temp nargs-tn (fixnumize (- register-arg-count)))
+ (move csp-tn ocfp-tn t)))
+
+ ;; Do the single value calse.
+ (do ((i 1 (1+ i))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i (min nvals register-arg-count)))
+ (move (tn-ref-tn val) null-tn))
+ (when (> nvals register-arg-count)
+ (inst b default-stack-vals)
+ (move ocfp-tn csp-tn t))
+
+ (emit-label regs-defaulted)
+
+ (when (> nvals register-arg-count)
+ ;; If there are stack results, we have to default them
+ ;; and clear the stack.
+ (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 blez temp default-lab)
+ (inst lw move-temp ocfp-tn (* i n-word-bytes))
+ (inst addu temp temp (fixnumize -1))
+ (store-stack-tn tn move-temp)))
+
+ (emit-label defaulting-done)
+ (move csp-tn ocfp-tn)
+
+ (let ((defaults (defaults)))
+ (aver defaults)
+ (assemble (*elsewhere*)
+ (emit-label default-stack-vals)
+ (do ((remaining defaults (cdr remaining)))
+ ((null remaining))
+ (let ((def (car remaining)))
+ (emit-label (car def))
+ (when (null (cdr remaining))
+ (inst b defaulting-done))
+ (store-stack-tn (cdr def) null-tn)))))))
+
+ (when lra-label
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))))
(values))
\f
(defun receive-unknown-values (args nargs start count lra-label temp)
(declare (type tn args nargs start count temp))
(let ((variable-values (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(without-scheduling ()
(inst b variable-values)
(inst nop))
(storew (first register-arg-tns) csp-tn -1)
(inst addu start csp-tn -4)
(inst li count (fixnumize 1))
-
+
(emit-label done)
-
+
(assemble (*elsewhere*)
(emit-label variable-values)
(when lra-label
- (inst compute-code-from-lra code-tn code-tn lra-label temp))
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))
(do ((arg register-arg-tns (rest arg))
- (i 0 (1+ i)))
- ((null arg))
- (storew (first arg) args i))
+ (i 0 (1+ i)))
+ ((null arg))
+ (storew (first arg) args i))
(move start args)
(inst b done)
(move count nargs t)))
(start :scs (any-reg))
(count :scs (any-reg)))
(:temporary (:sc descriptor-reg :offset ocfp-offset
- :from :eval :to (:result 0))
- values-start)
+ :from :eval :to (:result 0))
+ values-start)
(:temporary (:sc any-reg :offset nargs-offset
- :from :eval :to (:result 1))
- nvals)
+ :from :eval :to (:result 1))
+ nvals)
(:temporary (:scs (non-descriptor-reg)) temp))
;;;
(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)
(:ignore arg-locs args ocfp)
(:generator 5
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(trace-table-entry trace-table-call-site)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(inst nop)
(emit-return-pc label)
(default-unknown-values vop values nvals move-temp temp label)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))))
+ (load-stack-tn cur-nfp nfp-save)))))
;;; Non-TR local call for a variable number of return values passed according
;;;
(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)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:generator 20
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(trace-table-entry trace-table-call-site)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(inst nop)
(note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count label temp)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))))
+ (load-stack-tn cur-nfp nfp-save)))))
\f
;;;; Local call with known values return:
;;;
(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)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 5
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(trace-table-entry trace-table-call-site)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(inst nop)
(emit-return-pc label)
(note-this-location vop :known-return)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))))
+ (load-stack-tn cur-nfp nfp-save)))))
;;; Return from known values call. We receive the return locations as
;;; arguments to terminate their lifetimes in the returning function. We
;;;
(define-vop (known-return)
(:args (ocfp :target ocfp-temp)
- (return-pc :target return-pc-temp)
- (vals :more t))
+ (return-pc :target return-pc-temp)
+ (vals :more t))
(:temporary (:sc any-reg :from (:argument 0)) ocfp-temp)
(:temporary (:sc descriptor-reg :from (:argument 1))
- return-pc-temp)
+ return-pc-temp)
(:temporary (:scs (interior-reg)) lip)
(:move-args :known-return)
(:info val-locs)
(move csp-tn cfp-tn)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addu nsp-tn cur-nfp
- (bytes-needed-for-non-descriptor-stack-frame))))
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
(inst addu lip return-pc-temp (- n-word-bytes other-pointer-lowtag))
(inst j lip)
(move cfp-tn ocfp-temp t)
;;; replication in defining the cross-product VOPs.
;;;
;;; Name is the name of the VOP to define.
-;;;
+;;;
;;; Named is true if the first argument is a symbol whose global function
;;; definition is to be called.
;;;
(defmacro define-full-call (name named return variable)
(aver (not (and variable (eq return :tail))))
`(define-vop (,name
- ,@(when (eq return :unknown)
- '(unknown-values-receiver)))
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
(:args
,@(unless (eq return :tail)
- '((new-fp :scs (any-reg) :to :eval)))
+ '((new-fp :scs (any-reg) :to :eval)))
,(if named
- '(name :target name-pass)
- '(arg-fun :target lexenv))
-
+ '(name :target name-pass)
+ '(arg-fun :target lexenv))
+
,@(when (eq return :tail)
- '((ocfp :target ocfp-pass)
- (return-pc :target return-pc-pass)))
-
+ '((ocfp :target ocfp-pass)
+ (return-pc :target return-pc-pass)))
+
,@(unless variable '((args :more t :scs (descriptor-reg)))))
,@(when (eq return :fixed)
- '((:results (values :more t))))
-
+ '((:results (values :more t))))
+
(:save-p ,(if (eq return :tail) :compute-only t))
,@(unless (or (eq return :tail) variable)
- '((:move-args :full-call)))
+ '((:move-args :full-call)))
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(unless variable '(nargs))
+ ,@(when (eq return :fixed) '(nvals)))
(:ignore ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(args)))
+ ,@(unless variable '(args)))
(:temporary (:sc descriptor-reg
- :offset ocfp-offset
- :from (:argument 1)
- ,@(unless (eq return :fixed)
- '(:to :eval)))
- ocfp-pass)
+ :offset ocfp-offset
+ :from (:argument 1)
+ ,@(unless (eq return :fixed)
+ '(:to :eval)))
+ ocfp-pass)
(:temporary (:sc descriptor-reg
- :offset lra-offset
- :from (:argument ,(if (eq return :tail) 2 1))
- :to :eval)
- return-pc-pass)
+ :offset lra-offset
+ :from (:argument ,(if (eq return :tail) 2 1))
+ :to :eval)
+ return-pc-pass)
,@(if named
- `((:temporary (:sc descriptor-reg :offset fdefn-offset
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- name-pass))
-
- `((:temporary (:sc descriptor-reg :offset lexenv-offset
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- lexenv)
- (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
- function)))
+ `((:temporary (:sc descriptor-reg :offset fdefn-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ name-pass))
+
+ `((:temporary (:sc descriptor-reg :offset lexenv-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ lexenv)
+ (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
+ function)))
(:temporary (:sc any-reg :offset nargs-offset :to :eval)
- nargs-pass)
+ nargs-pass)
,@(when variable
- (mapcar #'(lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :to :eval)
- ,name))
- register-arg-names *register-arg-offsets*))
+ (mapcar #'(lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :to :eval)
+ ,name))
+ register-arg-names *register-arg-offsets*))
,@(when (eq return :fixed)
- '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+ '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
,@(unless (eq return :tail)
- '((:temporary (:scs (non-descriptor-reg)) temp)
- (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+ '((:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
(:temporary (:sc interior-reg :offset lip-offset) entry-point)
(:generator ,(+ (if named 5 0)
- (if variable 19 1)
- (if (eq return :tail) 0 10)
- 15
- (if (eq return :unknown) 25 0))
+ (if variable 19 1)
+ (if (eq return :tail) 0 10)
+ 15
+ (if (eq return :unknown) 25 0))
(let* ((cur-nfp (current-nfp-tn vop))
- ,@(unless (eq return :tail)
- '((lra-label (gen-label))))
- (filler
- (remove nil
- (list :load-nargs
- ,@(if (eq return :tail)
- '((unless (location= ocfp ocfp-pass)
- :load-ocfp)
- (unless (location= return-pc
- return-pc-pass)
- :load-return-pc)
- (when cur-nfp
- :frob-nfp))
- '(:comp-lra
- (when cur-nfp
- :frob-nfp)
- :save-fp
- :load-fp))))))
- (flet ((do-next-filler ()
- (let* ((next (pop filler))
- (what (if (consp next) (car next) next)))
- (ecase what
- (:load-nargs
- ,@(if variable
- `((inst subu nargs-pass csp-tn new-fp)
- ,@(let ((index -1))
- (mapcar #'(lambda (name)
- `(inst lw ,name new-fp
- ,(ash (incf index)
- word-shift)))
- register-arg-names)))
- '((inst li nargs-pass (fixnumize nargs)))))
- ,@(if (eq return :tail)
- '((:load-ocfp
- (sc-case ocfp
- (any-reg
- (move ocfp-pass ocfp t))
- (control-stack
- (inst lw ocfp-pass cfp-tn
- (ash (tn-offset ocfp)
- word-shift)))))
- (:load-return-pc
- (sc-case return-pc
- (descriptor-reg
- (move return-pc-pass return-pc t))
- (control-stack
- (inst lw return-pc-pass cfp-tn
- (ash (tn-offset return-pc)
- word-shift)))))
- (:frob-nfp
- (inst addu nsp-tn cur-nfp
- (bytes-needed-for-non-descriptor-stack-frame))))
- `((:comp-lra
- (inst compute-lra-from-code
- return-pc-pass code-tn lra-label temp))
- (:frob-nfp
- (store-stack-tn nfp-save cur-nfp))
- (:save-fp
- (move ocfp-pass cfp-tn t))
- (:load-fp
- ,(if variable
- '(move cfp-tn new-fp)
- '(if (> nargs register-arg-count)
- (move cfp-tn new-fp)
- (move cfp-tn csp-tn)))
- (trace-table-entry trace-table-call-site))))
- ((nil)
- (inst nop))))))
-
- ,@(if named
- `((sc-case name
- (descriptor-reg (move name-pass name))
- (control-stack
- (inst lw name-pass cfp-tn
- (ash (tn-offset name) word-shift))
- (do-next-filler))
- (constant
- (inst lw name-pass code-tn
- (- (ash (tn-offset name) word-shift)
- other-pointer-lowtag))
- (do-next-filler)))
- (inst lw entry-point name-pass
- (- (ash fdefn-raw-addr-slot word-shift)
- other-pointer-lowtag))
- (do-next-filler))
- `((sc-case arg-fun
- (descriptor-reg (move lexenv arg-fun))
- (control-stack
- (inst lw lexenv cfp-tn
- (ash (tn-offset arg-fun) word-shift))
- (do-next-filler))
- (constant
- (inst lw lexenv code-tn
- (- (ash (tn-offset arg-fun) word-shift)
- other-pointer-lowtag))
- (do-next-filler)))
- (inst lw function lexenv
- (- (ash closure-fun-slot word-shift)
- fun-pointer-lowtag))
- (do-next-filler)
- (inst addu entry-point function
- (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag))))
- (loop
- (if (cdr filler)
- (do-next-filler)
- (return)))
-
- (do-next-filler)
- (note-this-location vop :call-site)
- (inst j entry-point)
- (inst nop))
-
- ,@(ecase return
- (:fixed
- '((trace-table-entry trace-table-normal)
- (emit-return-pc lra-label)
- (default-unknown-values vop values nvals
- move-temp temp lra-label)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:unknown
- '((trace-table-entry trace-table-normal)
- (emit-return-pc lra-label)
- (note-this-location vop :unknown-return)
- (receive-unknown-values values-start nvals start count
- lra-label temp)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:tail))))))
+ ,@(unless (eq return :tail)
+ '((lra-label (gen-label))))
+ (filler
+ (remove nil
+ (list :load-nargs
+ ,@(if (eq return :tail)
+ '((unless (location= ocfp ocfp-pass)
+ :load-ocfp)
+ (unless (location= return-pc
+ return-pc-pass)
+ :load-return-pc)
+ (when cur-nfp
+ :frob-nfp))
+ '(:comp-lra
+ (when cur-nfp
+ :frob-nfp)
+ :save-fp
+ :load-fp))))))
+ (flet ((do-next-filler ()
+ (let* ((next (pop filler))
+ (what (if (consp next) (car next) next)))
+ (ecase what
+ (:load-nargs
+ ,@(if variable
+ `((inst subu nargs-pass csp-tn new-fp)
+ ,@(let ((index -1))
+ (mapcar #'(lambda (name)
+ `(inst lw ,name new-fp
+ ,(ash (incf index)
+ word-shift)))
+ register-arg-names)))
+ '((inst li nargs-pass (fixnumize nargs)))))
+ ,@(if (eq return :tail)
+ '((:load-ocfp
+ (sc-case ocfp
+ (any-reg
+ (move ocfp-pass ocfp t))
+ (control-stack
+ (inst lw ocfp-pass cfp-tn
+ (ash (tn-offset ocfp)
+ word-shift)))))
+ (:load-return-pc
+ (sc-case return-pc
+ (descriptor-reg
+ (move return-pc-pass return-pc t))
+ (control-stack
+ (inst lw return-pc-pass cfp-tn
+ (ash (tn-offset return-pc)
+ word-shift)))))
+ (:frob-nfp
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
+ `((:comp-lra
+ (inst compute-lra-from-code
+ return-pc-pass code-tn lra-label temp))
+ (:frob-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (:save-fp
+ (move ocfp-pass cfp-tn t))
+ (:load-fp
+ ,(if variable
+ '(move cfp-tn new-fp)
+ '(if (> nargs register-arg-count)
+ (move cfp-tn new-fp)
+ (move cfp-tn csp-tn)))
+ (trace-table-entry trace-table-call-site))))
+ ((nil)
+ (inst nop))))))
+
+ ,@(if named
+ `((sc-case name
+ (descriptor-reg (move name-pass name))
+ (control-stack
+ (inst lw name-pass cfp-tn
+ (ash (tn-offset name) word-shift))
+ (do-next-filler))
+ (constant
+ (inst lw name-pass code-tn
+ (- (ash (tn-offset name) word-shift)
+ other-pointer-lowtag))
+ (do-next-filler)))
+ (inst lw entry-point name-pass
+ (- (ash fdefn-raw-addr-slot word-shift)
+ other-pointer-lowtag))
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move lexenv arg-fun))
+ (control-stack
+ (inst lw lexenv cfp-tn
+ (ash (tn-offset arg-fun) word-shift))
+ (do-next-filler))
+ (constant
+ (inst lw lexenv code-tn
+ (- (ash (tn-offset arg-fun) word-shift)
+ other-pointer-lowtag))
+ (do-next-filler)))
+ (inst lw function lexenv
+ (- (ash closure-fun-slot word-shift)
+ fun-pointer-lowtag))
+ (do-next-filler)
+ (inst addu entry-point function
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))))
+ (loop
+ (if (cdr filler)
+ (do-next-filler)
+ (return)))
+
+ (do-next-filler)
+ (note-this-location vop :call-site)
+ (inst j entry-point)
+ (inst nop))
+
+ ,@(ecase return
+ (:fixed
+ '((trace-table-entry trace-table-normal)
+ (emit-return-pc lra-label)
+ (default-unknown-values vop values nvals
+ move-temp temp lra-label)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:unknown
+ '((trace-table-entry trace-table-normal)
+ (emit-return-pc lra-label)
+ (note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count
+ lra-label temp)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:tail))))))
(define-full-call call nil :fixed nil)
(inst j (make-fixup 'tail-call-variable :assembly-routine))
(let ((cur-nfp (current-nfp-tn vop)))
(if cur-nfp
- (inst addu nsp-tn cur-nfp
- (bytes-needed-for-non-descriptor-stack-frame))
- (inst nop)))))
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))
+ (inst nop)))))
\f
;;;; Unknown values return:
;;; Return a single value using the unknown-values convention.
-;;;
+;;;
(define-vop (return-single)
(:args (ocfp :scs (any-reg))
- (return-pc :scs (descriptor-reg))
- (value))
+ (return-pc :scs (descriptor-reg))
+ (value))
(:ignore value)
(:temporary (:scs (interior-reg)) lip)
(:vop-var vop)
(trace-table-entry trace-table-fun-epilogue)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addu nsp-tn cur-nfp
- (bytes-needed-for-non-descriptor-stack-frame))))
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
;; Clear the control stack, and restore the frame pointer.
(move csp-tn cfp-tn)
(move cfp-tn ocfp)
;;;
(define-vop (return)
(:args (ocfp :scs (any-reg))
- (return-pc :scs (descriptor-reg) :to (:eval 1))
- (values :more t))
+ (return-pc :scs (descriptor-reg) :to (:eval 1))
+ (values :more t))
(:ignore values)
(:info nvals)
(:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0)
(trace-table-entry trace-table-fun-epilogue)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addu nsp-tn cur-nfp
- (bytes-needed-for-non-descriptor-stack-frame))))
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
;; Establish the values pointer and values count.
(move val-ptr cfp-tn)
(inst li nargs (fixnumize nvals))
;; pre-default any argument register that need it.
(when (< nvals register-arg-count)
(dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
- (move reg null-tn)))
+ (move reg null-tn)))
;; And away we go.
(lisp-return return-pc lip)
(trace-table-entry trace-table-normal)))
;;;
(define-vop (return-multiple)
(:args (ocfp-arg :scs (any-reg) :target ocfp)
- (lra-arg :scs (descriptor-reg) :target lra)
- (vals-arg :scs (any-reg) :target vals)
- (nvals-arg :scs (any-reg) :target nvals))
+ (lra-arg :scs (descriptor-reg) :target lra)
+ (vals-arg :scs (any-reg) :target vals)
+ (nvals-arg :scs (any-reg) :target nvals))
(:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp)
(:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
(let ((not-single (gen-label)))
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
- (when cur-nfp
- (inst addu nsp-tn cur-nfp
- (bytes-needed-for-non-descriptor-stack-frame))))
+ (when cur-nfp
+ (inst addu nsp-tn cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame))))
;; Check for the single case.
(inst li a0 (fixnumize 1))
;;;
(define-vop (setup-closure-environment)
(:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
- :to (:result 0))
- lexenv)
+ :to (:result 0))
+ lexenv)
(:results (closure :scs (descriptor-reg)))
(:info label)
(:ignore label)
(move closure lexenv)))
;;; Copy a more arg from the argument area to the end of the current frame.
-;;; Fixed is the number of non-more arguments.
+;;; Fixed is the number of non-more arguments.
;;;
(define-vop (copy-more-arg)
(:temporary (:sc any-reg :offset nl0-offset) result)
(:info fixed)
(:generator 20
(let ((loop (gen-label))
- (do-regs (gen-label))
- (done (gen-label)))
+ (do-regs (gen-label))
+ (done (gen-label)))
(when (< fixed register-arg-count)
- ;; Save a pointer to the results so we can fill in register args.
- ;; We don't need this if there are more fixed args than reg args.
- (move result csp-tn))
+ ;; Save a pointer to the results so we can fill in register args.
+ ;; We don't need this if there are more fixed args than reg args.
+ (move result csp-tn))
;; Allocate the space on the stack.
(cond ((zerop fixed)
- (inst beq nargs-tn done)
- (inst addu csp-tn csp-tn nargs-tn))
- (t
- (inst addu count nargs-tn (fixnumize (- fixed)))
- (inst blez count done)
- (inst nop)
- (inst addu csp-tn csp-tn count)))
+ (inst beq nargs-tn done)
+ (inst addu csp-tn csp-tn nargs-tn))
+ (t
+ (inst addu count nargs-tn (fixnumize (- fixed)))
+ (inst blez count done)
+ (inst nop)
+ (inst addu csp-tn csp-tn count)))
(when (< fixed register-arg-count)
- ;; We must stop when we run out of stack args, not when we run out of
- ;; more args.
- (inst addu count nargs-tn (fixnumize (- register-arg-count))))
+ ;; We must stop when we run out of stack args, not when we run out of
+ ;; more args.
+ (inst addu count nargs-tn (fixnumize (- register-arg-count))))
;; Everything of interest in registers.
(inst blez count do-regs)
;; Initialize dst to be end of stack.
(emit-label do-regs)
(when (< fixed register-arg-count)
- ;; Now we have to deposit any more args that showed up in registers.
- ;; We know there is at least one more arg, otherwise we would have
- ;; branched to done up at the top.
- (inst subu count nargs-tn (fixnumize (1+ fixed)))
- (do ((i fixed (1+ i)))
- ((>= i register-arg-count))
- ;; Is this the last one?
- (inst beq count done)
- ;; Store it relative to the pointer saved at the start.
- (storew (nth i register-arg-tns) result (- i fixed))
- ;; Decrement count.
- (inst subu count (fixnumize 1))))
+ ;; Now we have to deposit any more args that showed up in registers.
+ ;; We know there is at least one more arg, otherwise we would have
+ ;; branched to done up at the top.
+ (inst subu count nargs-tn (fixnumize (1+ fixed)))
+ (do ((i fixed (1+ i)))
+ ((>= i register-arg-count))
+ ;; Is this the last one?
+ (inst beq count done)
+ ;; Store it relative to the pointer saved at the start.
+ (storew (nth i register-arg-tns) result (- i fixed))
+ ;; Decrement count.
+ (inst subu count (fixnumize 1))))
(emit-label done))))
;;;
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
- (count-arg :target count :scs (any-reg)))
+ (count-arg :target count :scs (any-reg)))
(:arg-types * tagged-num)
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
(:policy :safe)
(:generator 20
(let ((enter (gen-label))
- (loop (gen-label))
- (done (gen-label)))
+ (loop (gen-label))
+ (done (gen-label)))
(move context context-arg)
(move count count-arg)
;; Check to see if there are any arguments.
;; We need to do this atomically.
(pseudo-atomic (pa-flag)
- ;; Allocate a cons (2 words) for each item.
- (inst or result alloc-tn list-pointer-lowtag)
- (move dst result)
- (inst sll temp count 1)
- (inst b enter)
- (inst addu alloc-tn alloc-tn temp)
-
- ;; Store the current cons in the cdr of the previous cons.
- (emit-label loop)
- (inst addu dst dst (* 2 n-word-bytes))
- (storew dst dst -1 list-pointer-lowtag)
-
- (emit-label enter)
- ;; Grab one value.
- (loadw temp context)
- (inst addu context context n-word-bytes)
-
- ;; Dec count, and if != zero, go back for more.
- (inst addu count count (fixnumize -1))
- (inst bne count zero-tn loop)
-
- ;; Store the value in the car (in delay slot)
- (storew temp dst 0 list-pointer-lowtag)
-
- ;; NIL out the last cons.
- (storew null-tn dst 1 list-pointer-lowtag))
+ ;; Allocate a cons (2 words) for each item.
+ (inst or result alloc-tn list-pointer-lowtag)
+ (move dst result)
+ (inst sll temp count 1)
+ (inst b enter)
+ (inst addu alloc-tn alloc-tn temp)
+
+ ;; Store the current cons in the cdr of the previous cons.
+ (emit-label loop)
+ (inst addu dst dst (* 2 n-word-bytes))
+ (storew dst dst -1 list-pointer-lowtag)
+
+ (emit-label enter)
+ ;; Grab one value.
+ (loadw temp context)
+ (inst addu context context n-word-bytes)
+
+ ;; Dec count, and if != zero, go back for more.
+ (inst addu count count (fixnumize -1))
+ (inst bne count zero-tn loop)
+
+ ;; Store the value in the car (in delay slot)
+ (storew temp dst 0 list-pointer-lowtag)
+
+ ;; NIL out the last cons.
+ (storew null-tn dst 1 list-pointer-lowtag))
(emit-label done))))
;;; Return the location and size of the more arg glob created by Copy-More-Arg.
(:arg-types tagged-num (: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
(: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)))
(cond ((zerop count)
- (inst bne nargs zero-tn err-lab)
- (inst nop))
- (t
- (inst li temp (fixnumize count))
- (inst bne nargs temp err-lab)
- (inst nop))))))
+ (inst bne nargs zero-tn err-lab)
+ (inst nop))
+ (t
+ (inst li temp (fixnumize count))
+ (inst bne nargs temp err-lab)
+ (inst nop))))))
;;; Various other error signalers.
;;;
(macrolet ((frob (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)))))
(frob arg-count-error invalid-arg-count-error
sb!c::%arg-count-error nargs)
(frob 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 null zero)))
+ (value :scs (descriptor-reg any-reg null zero)))
(:info name offset lowtag)
(:ignore name)
(:results)
(loadw value object symbol-value-slot other-pointer-lowtag)
(inst xor temp value unbound-marker-widetag)
(if not-p
- (inst beq temp zero-tn target)
- (inst bne temp zero-tn target))
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn target))
(inst nop)))
(define-vop (fast-symbol-value cell-ref)
(:policy :fast-safe)
(:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
- (fdefn :scs (descriptor-reg)))
+ (fdefn :scs (descriptor-reg)))
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg)) type)
(:results (result :scs (descriptor-reg)))
(inst xor type simple-fun-header-widetag)
(inst beq type zero-tn normal-fn)
(inst addu lip function
- (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag))
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))
(inst li lip (make-fixup "closure_tramp" :foreign))
(emit-label normal-fn)
(storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
- (symbol :scs (descriptor-reg)))
+ (symbol :scs (descriptor-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:generator 5
(loadw temp symbol symbol-value-slot other-pointer-lowtag)
(:temporary (:scs (descriptor-reg)) symbol value)
(:generator 0
(let ((loop (gen-label))
- (skip (gen-label))
- (done (gen-label)))
+ (skip (gen-label))
+ (done (gen-label)))
(move where arg)
(inst beq where bsp-tn done)
(inst nop)
(:translate %raw-instance-ref/word)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:results (value :scs (unsigned-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(inst subu offset n-word-bytes)
(inst addu lip offset object)
(inst lw value lip (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))))
+ 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))
+ (index :scs (any-reg))
(value :scs (unsigned-reg) :target result))
(:arg-types * positive-fixnum unsigned-num)
(:results (result :scs (unsigned-reg)))
(inst subu offset n-word-bytes)
(inst addu lip offset object)
(inst sw value lip (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))
+ instance-pointer-lowtag))
(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)
(:results (value :scs (single-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(inst subu offset n-word-bytes)
(inst addu lip offset object)
(inst lwc1 value lip (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))))
+ 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))
+ (index :scs (any-reg))
(value :scs (single-reg) :target result))
(:arg-types * positive-fixnum single-float)
(:results (result :scs (single-reg)))
(inst subu offset n-word-bytes)
(inst addu lip offset object)
(inst swc1 value lip (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))
+ instance-pointer-lowtag))
(unless (location= result value)
(inst fmove :single 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)
(:results (value :scs (double-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(inst subu offset (* 2 n-word-bytes))
(inst addu lip offset object)
(let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag)))
+ instance-pointer-lowtag)))
(ecase *backend-byte-order*
- (:big-endian (inst lwc1 value lip immediate-offset))
- (:little-endian (inst lwc1-odd value lip immediate-offset))))
+ (:big-endian (inst lwc1 value lip immediate-offset))
+ (:little-endian (inst lwc1-odd value lip immediate-offset))))
(let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag)))
+ instance-pointer-lowtag)))
(ecase *backend-byte-order*
- (:big-endian (inst lwc1-odd value lip immediate-offset))
- (:little-endian (inst lwc1 value lip immediate-offset))))))
+ (:big-endian (inst lwc1-odd value lip immediate-offset))
+ (:little-endian (inst lwc1 value lip immediate-offset))))))
(define-vop (raw-instance-set/double)
(:translate %raw-instance-set/double)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
+ (index :scs (any-reg))
(value :scs (double-reg) :target result))
(:arg-types * positive-fixnum double-float)
(:results (result :scs (double-reg)))
(inst subu offset (* 2 n-word-bytes))
(inst addu lip offset object)
(let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag)))
+ instance-pointer-lowtag)))
(ecase *backend-byte-order*
- (:big-endian (inst swc1 value lip immediate-offset))
- (:little-endian (inst swc1-odd value lip immediate-offset))))
+ (:big-endian (inst swc1 value lip immediate-offset))
+ (:little-endian (inst swc1-odd value lip immediate-offset))))
(let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag)))
+ instance-pointer-lowtag)))
(ecase *backend-byte-order*
- (:big-endian (inst swc1-odd value lip immediate-offset))
- (:little-endian (inst swc1 value lip immediate-offset))))
+ (:big-endian (inst swc1-odd value lip immediate-offset))
+ (:little-endian (inst swc1 value lip immediate-offset))))
(unless (location= result value)
(inst fmove :double 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)
(:results (value :scs (complex-single-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(inst subu offset index)
(inst subu offset (* 2 n-word-bytes))
(inst addu lip offset object)
- (inst lwc1
- (complex-single-reg-real-tn value)
- lip
- (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))
(inst lwc1
- (complex-single-reg-imag-tn value)
- lip
- (- (* (1+ instance-slots-offset) n-word-bytes)
+ (complex-single-reg-real-tn value)
+ lip
+ (- (* instance-slots-offset n-word-bytes)
+ instance-pointer-lowtag))
+ (inst lwc1
+ (complex-single-reg-imag-tn value)
+ lip
+ (- (* (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))
+ (index :scs (any-reg))
(value :scs (complex-single-reg) :target result))
(:arg-types * positive-fixnum complex-single-float)
(:results (result :scs (complex-single-reg)))
(let ((value-real (complex-single-reg-real-tn value))
(result-real (complex-single-reg-real-tn result)))
(inst swc1
- value-real
+ value-real
lip
- (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag))
+ (- (* instance-slots-offset n-word-bytes)
+ instance-pointer-lowtag))
(unless (location= result-real value-real)
- (inst fmove :single result-real value-real)))
+ (inst fmove :single result-real value-real)))
(let ((value-imag (complex-single-reg-imag-tn value))
(result-imag (complex-single-reg-imag-tn result)))
(inst swc1
- value-imag
+ value-imag
lip
- (- (* (1+ instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag))
+ (- (* (1+ instance-slots-offset) n-word-bytes)
+ instance-pointer-lowtag))
(unless (location= result-imag value-imag)
- (inst fmove :single result-imag value-imag)))))
+ (inst fmove :single 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)
(:results (value :scs (complex-double-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(inst subu offset (* 4 n-word-bytes))
(inst addu lip offset object)
(let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag)))
+ instance-pointer-lowtag)))
(ecase *backend-byte-order*
- (:big-endian (inst lwc1
- (complex-double-reg-real-tn value)
- lip
- immediate-offset))
- (:little-endian (inst lwc1-odd
- (complex-double-reg-real-tn value)
- lip
- immediate-offset))))
+ (:big-endian (inst lwc1
+ (complex-double-reg-real-tn value)
+ lip
+ immediate-offset))
+ (:little-endian (inst lwc1-odd
+ (complex-double-reg-real-tn value)
+ lip
+ immediate-offset))))
(let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag)))
+ instance-pointer-lowtag)))
(ecase *backend-byte-order*
- (:big-endian (inst lwc1-odd
- (complex-double-reg-real-tn value)
- lip
- immediate-offset))
- (:little-endian (inst lwc1
- (complex-double-reg-real-tn value)
- lip
- immediate-offset))))
+ (:big-endian (inst lwc1-odd
+ (complex-double-reg-real-tn value)
+ lip
+ immediate-offset))
+ (:little-endian (inst lwc1
+ (complex-double-reg-real-tn value)
+ lip
+ immediate-offset))))
(let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)
- instance-pointer-lowtag)))
+ instance-pointer-lowtag)))
(ecase *backend-byte-order*
- (:big-endian (inst lwc1
- (complex-double-reg-imag-tn value)
- lip
- immediate-offset))
- (:little-endian (inst lwc1-odd
- (complex-double-reg-imag-tn value)
- lip
- immediate-offset))))
+ (:big-endian (inst lwc1
+ (complex-double-reg-imag-tn value)
+ lip
+ immediate-offset))
+ (:little-endian (inst lwc1-odd
+ (complex-double-reg-imag-tn value)
+ lip
+ immediate-offset))))
(let ((immediate-offset (- (* (+ instance-slots-offset 3) n-word-bytes)
- instance-pointer-lowtag)))
+ instance-pointer-lowtag)))
(ecase *backend-byte-order*
- (:big-endian (inst lwc1-odd
- (complex-double-reg-imag-tn value)
- lip
- immediate-offset))
- (:little-endian (inst lwc1
- (complex-double-reg-imag-tn value)
- lip
- immediate-offset))))))
+ (:big-endian (inst lwc1-odd
+ (complex-double-reg-imag-tn value)
+ lip
+ immediate-offset))
+ (:little-endian (inst lwc1
+ (complex-double-reg-imag-tn value)
+ lip
+ immediate-offset))))))
(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))
+ (index :scs (any-reg))
(value :scs (complex-double-reg) :target result))
(:arg-types * positive-fixnum complex-double-float)
(:results (result :scs (complex-double-reg)))
(let ((value-real (complex-double-reg-real-tn value))
(result-real (complex-double-reg-real-tn result)))
(let ((immediate-offset (- (* instance-slots-offset n-word-bytes)
- instance-pointer-lowtag)))
- (ecase *backend-byte-order*
- (:big-endian (inst swc1
- value-real
- lip
- immediate-offset))
- (:little-endian (inst swc1-odd
- value-real
- lip
- immediate-offset))))
+ instance-pointer-lowtag)))
+ (ecase *backend-byte-order*
+ (:big-endian (inst swc1
+ value-real
+ lip
+ immediate-offset))
+ (:little-endian (inst swc1-odd
+ value-real
+ lip
+ immediate-offset))))
(let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes)
- instance-pointer-lowtag)))
- (ecase *backend-byte-order*
- (:big-endian (inst swc1-odd
- value-real
- lip
- immediate-offset))
- (:little-endian (inst swc1
- value-real
- lip
- immediate-offset))))
+ instance-pointer-lowtag)))
+ (ecase *backend-byte-order*
+ (:big-endian (inst swc1-odd
+ value-real
+ lip
+ immediate-offset))
+ (:little-endian (inst swc1
+ value-real
+ lip
+ immediate-offset))))
(unless (location= result-real value-real)
- (inst fmove :double result-real value-real)))
+ (inst fmove :double result-real value-real)))
(let ((value-imag (complex-double-reg-imag-tn value))
(result-imag (complex-double-reg-imag-tn result)))
(let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes)
- instance-pointer-lowtag)))
- (ecase *backend-byte-order*
- (:big-endian (inst swc1
- value-imag
- lip
- immediate-offset))
- (:little-endian (inst swc1-odd
- value-imag
- lip
- immediate-offset))))
+ instance-pointer-lowtag)))
+ (ecase *backend-byte-order*
+ (:big-endian (inst swc1
+ value-imag
+ lip
+ immediate-offset))
+ (:little-endian (inst swc1-odd
+ value-imag
+ lip
+ immediate-offset))))
(let ((immediate-offset (- (* (+ instance-slots-offset 3) n-word-bytes)
- instance-pointer-lowtag)))
- (ecase *backend-byte-order*
- (:big-endian (inst swc1-odd
- value-imag
- lip
- immediate-offset))
- (:little-endian (inst swc1
- value-imag
- lip
- immediate-offset))))
+ instance-pointer-lowtag)))
+ (ecase *backend-byte-order*
+ (:big-endian (inst swc1-odd
+ value-imag
+ lip
+ immediate-offset))
+ (:little-endian (inst swc1
+ value-imag
+ lip
+ immediate-offset))))
(unless (location= result-imag value-imag)
- (inst fmove :double result-imag value-imag)))))
+ (inst fmove :double result-imag value-imag)))))
;;; 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)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:effects)
(:affected)
(:generator 0
;;; 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))
(:generator 0
(sc-case y
;;;
(define-vop (character-compare pointer-compare)
(:args (x :scs (character-reg))
- (y :scs (character-reg)))
+ (y :scs (character-reg)))
(:arg-types character character))
(define-vop (fast-char=/character character-compare)
(:translate stack-ref)
(:policy :fast-safe)
(:args (object :scs (sap-reg) :target sap)
- (offset :scs (any-reg)))
+ (offset :scs (any-reg)))
(:arg-types system-area-pointer positive-fixnum)
(:temporary (:scs (sap-reg) :from :eval) sap)
(:results (result :scs (descriptor-reg)))
(:translate %set-stack-ref)
(:policy :fast-safe)
(:args (object :scs (sap-reg) :target sap)
- (offset :scs (any-reg))
- (value :scs (descriptor-reg) :target result))
+ (offset :scs (any-reg))
+ (value :scs (descriptor-reg) :target result))
(:arg-types system-area-pointer positive-fixnum *)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(: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 offset)
(:arg-types system-area-pointer (:constant (signed-byte 14)) *)
(:results (result :scs (descriptor-reg)))
(:variant-vars lowtag)
(:generator 5
(let ((bogus (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(loadw temp thing 0 lowtag)
(inst srl temp n-widetag-bits)
(inst beq temp bogus)
(inst sll temp (1- (integer-length n-word-bytes)))
(unless (= lowtag other-pointer-lowtag)
- (inst addu temp (- lowtag other-pointer-lowtag)))
+ (inst addu temp (- lowtag other-pointer-lowtag)))
(inst subu code thing temp)
(emit-label done)
(assemble (*elsewhere*)
- (emit-label bogus)
- (inst b done)
- (move code null-tn t)))))
+ (emit-label bogus)
+ (inst b done)
+ (move code null-tn t)))))
(define-vop (code-from-lra code-from-mumble)
(:translate lra-code-header)
(:little-endian
(inst lwc1 r base offset)
(inst lwc1-odd r base (+ offset n-word-bytes)))))
-
+
(define-move-fun (load-double 2) (vop x y)
((double-stack) (double-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(ld-double y nfp offset))
(inst nop))
(define-move-fun (store-double 2) (vop x y)
((double-reg) (double-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(str-double x nfp offset)))
\f
;;;; Move VOPs:
(macrolet ((frob (vop sc format)
- `(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 fmove ,format 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 fmove ,format y x))))
+ (define-move-vop ,vop :move (,sc) (,sc)))))
(frob single-move single-reg :single)
(frob double-move double-reg :double))
(:generator 13
(with-fixed-allocation (y pa-flag ndescr type size)
(if double-p
- (str-double x y (- (* data n-word-bytes) other-pointer-lowtag))
- (inst swc1 x y (- (* data n-word-bytes) other-pointer-lowtag))))))
+ (str-double x y (- (* data n-word-bytes) other-pointer-lowtag))
+ (inst swc1 x y (- (* data n-word-bytes) other-pointer-lowtag))))))
(macrolet ((frob (name sc &rest args)
- `(progn
- (define-vop (,name move-from-float)
- (:args (x :scs (,sc) :to :save))
- (:results (y :scs (descriptor-reg)))
- (:variant ,@args))
- (define-move-vop ,name :move (,sc) (descriptor-reg)))))
+ `(progn
+ (define-vop (,name move-from-float)
+ (:args (x :scs (,sc) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:variant ,@args))
+ (define-move-vop ,name :move (,sc) (descriptor-reg)))))
(frob move-from-single single-reg
nil single-float-size single-float-widetag single-float-value-slot)
(frob move-from-double double-reg
t double-float-size double-float-widetag double-float-value-slot))
(macrolet ((frob (name sc double-p value)
- `(progn
- (define-vop (,name)
- (:args (x :scs (descriptor-reg)))
- (:results (y :scs (,sc)))
- (:note "pointer to float coercion")
- (:generator 2
- ,@(ecase *backend-byte-order*
- (:big-endian
- (cond
- (double-p
- `((inst lwc1 y x (- (* (1+ ,value) n-word-bytes)
- other-pointer-lowtag))
- (inst lwc1-odd y x (- (* ,value n-word-bytes)
- other-pointer-lowtag))))
- (t
- `((inst lwc1 y x (- (* ,value n-word-bytes)
- other-pointer-lowtag))))))
- (:little-endian
- `((inst lwc1 y x (- (* ,value n-word-bytes)
- other-pointer-lowtag))
- ,@(when double-p
- `((inst lwc1-odd y x
- (- (* (1+ ,value) n-word-bytes)
- other-pointer-lowtag)))))))
- (inst nop)))
- (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (,sc)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ ,@(ecase *backend-byte-order*
+ (:big-endian
+ (cond
+ (double-p
+ `((inst lwc1 y x (- (* (1+ ,value) n-word-bytes)
+ other-pointer-lowtag))
+ (inst lwc1-odd y x (- (* ,value n-word-bytes)
+ other-pointer-lowtag))))
+ (t
+ `((inst lwc1 y x (- (* ,value n-word-bytes)
+ other-pointer-lowtag))))))
+ (:little-endian
+ `((inst lwc1 y x (- (* ,value n-word-bytes)
+ other-pointer-lowtag))
+ ,@(when double-p
+ `((inst lwc1-odd y x
+ (- (* (1+ ,value) n-word-bytes)
+ other-pointer-lowtag)))))))
+ (inst nop)))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-single single-reg nil single-float-value-slot)
(frob move-to-double double-reg t double-float-value-slot))
(macrolet ((frob (name sc stack-sc format double-p)
- `(progn
- (define-vop (,name)
- (:args (x :scs (,sc) :target y)
- (nfp :scs (any-reg)
- :load-if (not (sc-is y ,sc))))
- (:results (y))
- (:note "float argument move")
- (:generator ,(if double-p 2 1)
- (sc-case y
- (,sc
- (unless (location= x y)
- (inst fmove ,format y x)))
- (,stack-sc
- (let ((offset (* (tn-offset y) n-word-bytes)))
- ,@(ecase *backend-byte-order*
- (:big-endian
- (cond
- (double-p
- '((inst swc1 x nfp (+ offset n-word-bytes))
- (inst swc1-odd x nfp offset)))
- (t
- '((inst swc1 x nfp offset)))))
- (:little-endian
- `((inst swc1 x nfp offset)
- ,@(when double-p
- '((inst swc1-odd x nfp
- (+ offset n-word-bytes))))))))))))
- (define-move-vop ,name :move-arg
- (,sc descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (nfp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "float argument move")
+ (:generator ,(if double-p 2 1)
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (inst fmove ,format y x)))
+ (,stack-sc
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ ,@(ecase *backend-byte-order*
+ (:big-endian
+ (cond
+ (double-p
+ '((inst swc1 x nfp (+ offset n-word-bytes))
+ (inst swc1-odd x nfp offset)))
+ (t
+ '((inst swc1 x nfp offset)))))
+ (:little-endian
+ `((inst swc1 x nfp offset)
+ ,@(when double-p
+ '((inst swc1-odd x nfp
+ (+ offset n-word-bytes))))))))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
(frob move-single-float-arg single-reg single-stack :single nil)
(frob move-double-float-arg double-reg double-stack :double t))
\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 (+ (tn-offset x) 2)))
+ :offset (+ (tn-offset x) 2)))
(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 (+ (tn-offset x) 2)))
+ :offset (+ (tn-offset x) 2)))
(define-move-fun (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(let ((real-tn (complex-single-reg-real-tn y)))
(inst lwc1 real-tn nfp offset))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(define-move-fun (store-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(let ((real-tn (complex-single-reg-real-tn x)))
(inst swc1 real-tn nfp offset))
(let ((imag-tn (complex-single-reg-imag-tn x)))
(define-move-fun (load-complex-double 4) (vop x y)
((complex-double-stack) (complex-double-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(let ((real-tn (complex-double-reg-real-tn y)))
(ld-double real-tn nfp offset))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(define-move-fun (store-complex-double 4) (vop x y)
((complex-double-reg) (complex-double-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(let ((real-tn (complex-double-reg-real-tn x)))
(str-double real-tn nfp offset))
(let ((imag-tn (complex-double-reg-imag-tn x)))
;;; Complex float register to register moves.
(define-vop (complex-single-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))))
(:note "complex single float move")
(:generator 0
;; 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-single-reg-real-tn x))
- (y-real (complex-single-reg-real-tn y)))
- (inst fmove :single y-real x-real))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmove :single y-real x-real))
(let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst fmove :single y-imag x-imag)))))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmove :single y-imag x-imag)))))
(define-move-vop complex-single-move :move
(complex-single-reg) (complex-single-reg))
(define-vop (complex-double-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))))
(:note "complex double float move")
(:generator 0
;; 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)))
- (inst fmove :double y-real x-real))
+ (y-real (complex-double-reg-real-tn y)))
+ (inst fmove :double y-real x-real))
(let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (inst fmove :double y-imag x-imag)))))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fmove :double y-imag x-imag)))))
(define-move-vop complex-double-move :move
(complex-double-reg) (complex-double-reg))
(:note "complex single float to pointer coercion")
(:generator 13
(with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag
- complex-single-float-size)
+ complex-single-float-size)
(let ((real-tn (complex-single-reg-real-tn x)))
- (inst swc1 real-tn y (- (* complex-single-float-real-slot
- n-word-bytes)
- other-pointer-lowtag)))
+ (inst swc1 real-tn y (- (* complex-single-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
(let ((imag-tn (complex-single-reg-imag-tn x)))
- (inst swc1 imag-tn y (- (* complex-single-float-imag-slot
- n-word-bytes)
- other-pointer-lowtag))))))
+ (inst swc1 imag-tn y (- (* complex-single-float-imag-slot
+ n-word-bytes)
+ other-pointer-lowtag))))))
(define-move-vop move-from-complex-single :move
(complex-single-reg) (descriptor-reg))
(:note "complex double float to pointer coercion")
(:generator 13
(with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag
- complex-double-float-size)
+ complex-double-float-size)
(let ((real-tn (complex-double-reg-real-tn x)))
- (str-double real-tn y (- (* complex-double-float-real-slot
- n-word-bytes)
- other-pointer-lowtag)))
+ (str-double real-tn y (- (* complex-double-float-real-slot
+ n-word-bytes)
+ other-pointer-lowtag)))
(let ((imag-tn (complex-double-reg-imag-tn x)))
- (str-double imag-tn y (- (* complex-double-float-imag-slot
- n-word-bytes)
- other-pointer-lowtag))))))
+ (str-double imag-tn y (- (* complex-double-float-imag-slot
+ n-word-bytes)
+ other-pointer-lowtag))))))
(define-move-vop move-from-complex-double :move
(complex-double-reg) (descriptor-reg))
(:generator 2
(let ((real-tn (complex-single-reg-real-tn y)))
(inst lwc1 real-tn x (- (* complex-single-float-real-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(inst lwc1 imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(inst nop)))
(define-move-vop move-to-complex-single :move
(descriptor-reg) (complex-single-reg))
(:generator 2
(let ((real-tn (complex-double-reg-real-tn y)))
(ld-double real-tn x (- (* complex-double-float-real-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(ld-double imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(inst nop)))
(define-move-vop move-to-complex-double :move
(descriptor-reg) (complex-double-reg))
;;; complex float MOVE-ARG VOP
(define-vop (move-complex-single-float-arg)
(:args (x :scs (complex-single-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
(:results (y))
(:note "complex single-float argument move")
(:generator 1
(sc-case y
(complex-single-reg
(unless (location= x y)
- (let ((x-real (complex-single-reg-real-tn x))
- (y-real (complex-single-reg-real-tn y)))
- (inst fmove :single y-real x-real))
- (let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst fmove :single y-imag x-imag))))
+ (let ((x-real (complex-single-reg-real-tn x))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmove :single y-real x-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmove :single y-imag x-imag))))
(complex-single-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-single-reg-real-tn x)))
- (inst swc1 real-tn nfp offset))
- (let ((imag-tn (complex-single-reg-imag-tn x)))
- (inst swc1 imag-tn nfp (+ offset n-word-bytes))))))))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst swc1 real-tn nfp offset))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst swc1 imag-tn nfp (+ offset n-word-bytes))))))))
(define-move-vop move-complex-single-float-arg :move-arg
(complex-single-reg descriptor-reg) (complex-single-reg))
(define-vop (move-complex-double-float-arg)
(:args (x :scs (complex-double-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
(:results (y))
(:note "complex double-float argument move")
(:generator 2
(sc-case y
(complex-double-reg
(unless (location= x y)
- (let ((x-real (complex-double-reg-real-tn x))
- (y-real (complex-double-reg-real-tn y)))
- (inst fmove :double y-real x-real))
- (let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (inst fmove :double y-imag x-imag))))
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (inst fmove :double y-real x-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fmove :double y-imag x-imag))))
(complex-double-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-double-reg-real-tn x)))
- (str-double real-tn nfp offset))
- (let ((imag-tn (complex-double-reg-imag-tn x)))
- (str-double imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (str-double real-tn nfp offset))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (str-double imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
(define-move-vop move-complex-double-float-arg :move-arg
(complex-double-reg descriptor-reg) (complex-double-reg))
(inst float-op operation format r x y)))
(macrolet ((frob (name sc ptype)
- `(define-vop (,name float-op)
- (:args (x :scs (,sc))
- (y :scs (,sc)))
- (:results (r :scs (,sc)))
- (:arg-types ,ptype ,ptype)
- (:result-types ,ptype))))
+ `(define-vop (,name float-op)
+ (:args (x :scs (,sc))
+ (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 ((frob (op sname scost dname dcost)
- `(progn
- (define-vop (,sname single-float-op)
- (:translate ,op)
- (:variant :single ',op)
- (:variant-cost ,scost))
- (define-vop (,dname double-float-op)
- (:translate ,op)
- (:variant :double ',op)
- (:variant-cost ,dcost)))))
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,op)
+ (:variant :single ',op)
+ (:variant-cost ,scost))
+ (define-vop (,dname double-float-op)
+ (:translate ,op)
+ (:variant :double ',op)
+ (:variant-cost ,dcost)))))
(frob + +/single-float 2 +/double-float 2)
(frob - -/single-float 2 -/double-float 2)
(frob * */single-float 4 */double-float 5)
(frob / //single-float 12 //double-float 19))
(macrolet ((frob (name inst translate format sc type)
- `(define-vop (,name)
- (:args (x :scs (,sc)))
- (:results (y :scs (,sc)))
- (:translate ,translate)
- (:policy :fast-safe)
- (:arg-types ,type)
- (:result-types ,type)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 1
- (note-this-location vop :internal-error)
- (inst ,inst ,format y x)))))
+ `(define-vop (,name)
+ (:args (x :scs (,sc)))
+ (:results (y :scs (,sc)))
+ (:translate ,translate)
+ (:policy :fast-safe)
+ (:arg-types ,type)
+ (:result-types ,type)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ (inst ,inst ,format y x)))))
(frob abs/single-float fabs abs :single single-reg single-float)
(frob abs/double-float fabs abs :double double-reg double-float)
(frob %negate/single-float fneg %negate :single single-reg single-float)
(inst fcmp operation format x y)
(inst nop)
(if (if complement (not not-p) not-p)
- (inst bc1f target)
- (inst bc1t target))
+ (inst bc1f target)
+ (inst bc1t target))
(inst nop)))
(macrolet ((frob (name sc ptype)
- `(define-vop (,name float-compare)
- (:args (x :scs (,sc))
- (y :scs (,sc)))
- (:arg-types ,ptype ,ptype))))
+ `(define-vop (,name float-compare)
+ (:args (x :scs (,sc))
+ (y :scs (,sc)))
+ (:arg-types ,ptype ,ptype))))
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float))
(macrolet ((frob (translate op complement sname dname)
- `(progn
- (define-vop (,sname single-float-compare)
- (:translate ,translate)
- (:variant :single ,op ,complement))
- (define-vop (,dname double-float-compare)
- (:translate ,translate)
- (:variant :double ,op ,complement)))))
+ `(progn
+ (define-vop (,sname single-float-compare)
+ (:translate ,translate)
+ (:variant :single ,op ,complement))
+ (define-vop (,dname double-float-compare)
+ (:translate ,translate)
+ (:variant :double ,op ,complement)))))
(frob < :lt nil </single-float </double-float)
(frob > :ngt t >/single-float >/double-float)
(frob = :seq nil =/single-float =/double-float))
;;;; Conversion:
(macrolet ((frob (name translate
- from-sc from-type from-format
- to-sc to-type to-format)
- (let ((word-p (eq from-format :word)))
- `(define-vop (,name)
- (:args (x :scs (,from-sc)))
- (: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 ,(if word-p 3 2)
- ,@(if word-p
- `((inst mtc1 y x)
- (inst nop)
- (note-this-location vop :internal-error)
- (inst fcvt ,to-format :word y y))
- `((note-this-location vop :internal-error)
- (inst fcvt ,to-format ,from-format y x))))))))
+ from-sc from-type from-format
+ to-sc to-type to-format)
+ (let ((word-p (eq from-format :word)))
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc)))
+ (: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 ,(if word-p 3 2)
+ ,@(if word-p
+ `((inst mtc1 y x)
+ (inst nop)
+ (note-this-location vop :internal-error)
+ (inst fcvt ,to-format :word y y))
+ `((note-this-location vop :internal-error)
+ (inst fcvt ,to-format ,from-format y x))))))))
(frob %single-float/signed %single-float
signed-reg signed-num :word
single-reg single-float :single)
(macrolet ((frob (name from-sc from-type from-format)
- `(define-vop (,name)
- (:args (x :scs (,from-sc)))
- (:results (y :scs (signed-reg)))
- (:temporary (:from (:argument 0) :sc ,from-sc) temp)
- (:arg-types ,from-type)
- (:result-types signed-num)
- (:translate %unary-round)
- (:policy :fast-safe)
- (:note "inline float round")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 3
- (note-this-location vop :internal-error)
- (inst fcvt :word ,from-format temp x)
- (inst mfc1 y temp)
- (inst nop)))))
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc)))
+ (:results (y :scs (signed-reg)))
+ (:temporary (:from (:argument 0) :sc ,from-sc) temp)
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate %unary-round)
+ (:policy :fast-safe)
+ (:note "inline float round")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 3
+ (note-this-location vop :internal-error)
+ (inst fcvt :word ,from-format temp x)
+ (inst mfc1 y temp)
+ (inst nop)))))
(frob %unary-round/single-float single-reg single-float :single)
(frob %unary-round/double-float double-reg double-float :double))
;;; the desired round-to-zero behavior.
;;;
(macrolet ((frob (name from-sc from-type from-format)
- `(define-vop (,name)
- (:args (x :scs (,from-sc)))
- (:results (y :scs (signed-reg)))
- (:temporary (:from (:argument 0) :sc ,from-sc) temp)
- (:temporary (:sc non-descriptor-reg) status-save new-status)
- (:temporary (:sc non-descriptor-reg :offset nl4-offset)
- pa-flag)
- (:arg-types ,from-type)
- (:result-types signed-num)
- (:translate %unary-truncate)
- (:policy :fast-safe)
- (:note "inline float truncate")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 16
- (pseudo-atomic (pa-flag)
- (inst cfc1 status-save 31)
- (inst li new-status (lognot 3))
- (inst and new-status status-save)
- (inst or new-status float-round-to-zero)
- (inst ctc1 new-status 31)
-
- ;; These instructions seem to be necessary to ensure that
- ;; the new modes affect the fcvt instruction.
- (inst nop)
- (inst cfc1 new-status 31)
-
- (note-this-location vop :internal-error)
- (inst fcvt :word ,from-format temp x)
- (inst mfc1 y temp)
- (inst nop)
- (inst ctc1 status-save 31))))))
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc)))
+ (:results (y :scs (signed-reg)))
+ (:temporary (:from (:argument 0) :sc ,from-sc) temp)
+ (:temporary (:sc non-descriptor-reg) status-save new-status)
+ (:temporary (:sc non-descriptor-reg :offset nl4-offset)
+ pa-flag)
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate %unary-truncate)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 16
+ (pseudo-atomic (pa-flag)
+ (inst cfc1 status-save 31)
+ (inst li new-status (lognot 3))
+ (inst and new-status status-save)
+ (inst or new-status float-round-to-zero)
+ (inst ctc1 new-status 31)
+
+ ;; These instructions seem to be necessary to ensure that
+ ;; the new modes affect the fcvt instruction.
+ (inst nop)
+ (inst cfc1 new-status 31)
+
+ (note-this-location vop :internal-error)
+ (inst fcvt :word ,from-format temp x)
+ (inst mfc1 y temp)
+ (inst nop)
+ (inst ctc1 status-save 31))))))
(frob %unary-truncate/single-float single-reg single-float :single)
(frob %unary-truncate/double-float double-reg double-float :double))
(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)))
(:arg-types signed-num unsigned-num)
(:result-types double-float)
(define-vop (make-complex-single-float)
(:translate complex)
(:args (real :scs (single-reg) :target r)
- (imag :scs (single-reg) :to :save))
+ (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 fmove :single r-real real)))
+ (unless (location= real r-real)
+ (inst fmove :single r-real real)))
(let ((r-imag (complex-single-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst fmove :single r-imag imag))))
+ (unless (location= imag r-imag)
+ (inst fmove :single r-imag imag))))
(complex-single-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (inst swc1 real nfp offset)
- (inst swc1 imag nfp (+ offset n-word-bytes)))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (inst swc1 real nfp offset)
+ (inst swc1 imag nfp (+ offset n-word-bytes)))))))
(define-vop (make-complex-double-float)
(:translate complex)
(:args (real :scs (double-reg) :target r)
- (imag :scs (double-reg) :to :save))
+ (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 fmove :double r-real real)))
+ (unless (location= real r-real)
+ (inst fmove :double r-real real)))
(let ((r-imag (complex-double-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst fmove :double r-imag imag))))
+ (unless (location= imag r-imag)
+ (inst fmove :double r-imag imag))))
(complex-double-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (str-double real nfp offset)
- (str-double imag nfp (+ offset (* 2 n-word-bytes))))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (str-double real nfp offset)
+ (str-double imag nfp (+ offset (* 2 n-word-bytes))))))))
(define-vop (complex-single-float-value)
(:args (x :scs (complex-single-reg) :target r
- :load-if (not (sc-is x complex-single-stack))))
+ :load-if (not (sc-is x complex-single-stack))))
(:arg-types complex-single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(sc-case x
(complex-single-reg
(let ((value-tn (ecase slot
- (:real (complex-single-reg-real-tn x))
- (:imag (complex-single-reg-imag-tn x)))))
- (unless (location= value-tn r)
- (inst fmove :single r value-tn))))
+ (:real (complex-single-reg-real-tn x))
+ (:imag (complex-single-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst fmove :single r value-tn))))
(complex-single-stack
(inst lwc1 r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
- (tn-offset x))
- n-word-bytes))
+ (tn-offset x))
+ n-word-bytes))
(inst nop)))))
(define-vop (realpart/complex-single-float complex-single-float-value)
(define-vop (complex-double-float-value)
(:args (x :scs (complex-double-reg) :target r
- :load-if (not (sc-is x complex-double-stack))))
+ :load-if (not (sc-is x complex-double-stack))))
(:arg-types complex-double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(sc-case x
(complex-double-reg
(let ((value-tn (ecase slot
- (:real (complex-double-reg-real-tn x))
- (:imag (complex-double-reg-imag-tn x)))))
- (unless (location= value-tn r)
- (inst fmove :double r value-tn))))
+ (:real (complex-double-reg-real-tn x))
+ (:imag (complex-double-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst fmove :double r value-tn))))
(complex-double-stack
(ld-double r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
- (tn-offset x))
- n-word-bytes))
+ (tn-offset x))
+ n-word-bytes))
(inst nop)))))
(define-vop (realpart/complex-double-float complex-double-float-value)
(null null-offset)
(t
(if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
- (tn-offset tn)
- (error "~S isn't a register." tn)))))
+ (tn-offset tn)
+ (error "~S isn't a register." tn)))))
(defun fp-reg-tn-encoding (tn)
(declare (type tn tn))
(tn
(ecase (sb-name (sc-sb (tn-sc loc)))
(immediate-constant
- ;; Can happen if $ZERO or $NULL are passed in.
- nil)
+ ;; Can happen if $ZERO or $NULL are passed in.
+ nil)
(registers
- (unless (zerop (tn-offset loc))
- (tn-offset loc)))
+ (unless (zerop (tn-offset loc))
+ (tn-offset loc)))
(float-registers
- (+ (tn-offset loc) 32))))
+ (+ (tn-offset loc) 32))))
(symbol
(ecase loc
(:memory 0)
(defparameter reg-symbols
(map 'vector
#'(lambda (name)
- (cond ((null name) nil)
- (t (make-symbol (concatenate 'string "$" name)))))
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "$" name)))))
*register-names*))
(sb!disassem:define-arg-type reg
:printer #'(lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'registers
- regname
- dstate))))
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'registers
+ regname
+ dstate))))
(defparameter float-reg-symbols
- #.(coerce
+ #.(coerce
(loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
'vector))
(sb!disassem:define-arg-type fp-reg
:printer #'(lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref float-reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'float-registers
- regname
- dstate))))
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref float-reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'float-registers
+ regname
+ dstate))))
(sb!disassem:define-arg-type control-reg
:printer "(CR:#x~X)")
(sb!disassem:define-arg-type relative-label
:sign-extend t
:use-label #'(lambda (value dstate)
- (declare (type (signed-byte 16) value)
- (type sb!disassem:disassem-state dstate))
- (+ (ash (1+ value) 2) (sb!disassem:dstate-cur-addr dstate))))
+ (declare (type (signed-byte 16) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash (1+ value) 2) (sb!disassem:dstate-cur-addr dstate))))
(deftype float-format ()
'(member :s :single :d :double :w :word))
(sb!disassem:define-arg-type float-format
:printer #'(lambda (value stream dstate)
- (declare (ignore dstate)
- (stream stream)
- (fixnum value))
- (princ (case value
- (0 's)
- (1 'd)
- (4 'w)
- (t '?))
- stream)))
+ (declare (ignore dstate)
+ (stream stream)
+ (fixnum value))
+ (princ (case value
+ (0 's)
+ (1 'd)
+ (4 'w)
+ (t '?))
+ stream)))
(defconstant-eqx compare-kinds
'(:f :un :eq :ueq :olt :ult :ole :ule :sf :ngle :seq :ngl :lt :nge :le :ngt)
(defun compare-kind (kind)
(or (position kind compare-kinds)
(error "Unknown floating point compare kind: ~S~%Must be one of: ~S"
- kind
- compare-kinds)))
+ kind
+ compare-kinds)))
(sb!disassem:define-arg-type compare-kind
:printer compare-kinds-vec)
(defun float-operation (op)
(or (position op float-operations)
(error "Unknown floating point operation: ~S~%Must be one of: ~S"
- op
- float-operations)))
+ op
+ float-operations)))
(sb!disassem:define-arg-type float-operation
:printer float-operation-names)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter jump-printer
#'(lambda (value stream dstate)
- (let ((addr (ash value 2)))
- (sb!disassem:maybe-note-assembler-routine addr t dstate)
- (write addr :base 16 :radix t :stream stream)))))
+ (let ((addr (ash value 2)))
+ (sb!disassem:maybe-note-assembler-routine addr t dstate)
+ (write addr :base 16 :radix t :stream stream)))))
(sb!disassem:define-instruction-format
(jump 32 :default-printer '(:name :tab target))
(sb!disassem:define-instruction-format
(break 32 :default-printer
- '(:name :tab code (:unless (:constant 0) subcode)))
+ '(:name :tab code (:unless (:constant 0) subcode)))
(op :field (byte 6 26) :value special-op)
(code :field (byte 10 16))
(subcode :field (byte 10 6) :value 0)
(defconstant-eqx float-printer
`(:name ,@float-fmt-printer
- :tab
- fd
- (:unless (:same-as fd) ", " fs)
- ", " ft)
+ :tab
+ fd
+ (:unless (:same-as fd) ", " fs)
+ ", " ft)
#'equalp)
(sb!disassem:define-instruction-format
(sb!disassem:define-instruction-format
(float-op 32
- :include 'float
- :default-printer
- '('f funct "." format
- :tab
- fd
- (:unless (:same-as fd) ", " fs)
- ", " ft))
+ :include 'float
+ :default-printer
+ '('f funct "." format
+ :tab
+ fd
+ (:unless (:same-as fd) ", " fs)
+ ", " ft))
(funct :field (byte 2 0) :type 'float-operation)
(funct-filler :field (byte 4 2) :value 0)
(ft :value nil :type 'fp-reg))
;;;; Math instructions.
(defun emit-math-inst (segment dst src1 src2 reg-opcode immed-opcode
- &optional allow-fixups)
+ &optional allow-fixups)
(unless src2
(setf src2 src1)
(setf src1 dst))
(etypecase src2
(tn
(emit-register-inst segment special-op (reg-tn-encoding src1)
- (reg-tn-encoding src2) (reg-tn-encoding dst)
- 0 reg-opcode))
+ (reg-tn-encoding src2) (reg-tn-encoding dst)
+ 0 reg-opcode))
(integer
(emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
- (reg-tn-encoding dst) src2))
+ (reg-tn-encoding dst) src2))
(fixup
(unless allow-fixups
(error "Fixups aren't allowed."))
(note-fixup segment :addi src2)
(emit-immediate-inst segment immed-opcode (reg-tn-encoding src1)
- (reg-tn-encoding dst) 0))))
+ (reg-tn-encoding dst) 0))))
(define-instruction add (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (signed-byte 16) null) src1 src2))
+ (type (or tn (signed-byte 16) null) src1 src2))
(:printer register ((op special-op) (funct #b100000)))
(:printer immediate ((op #b001000)))
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(define-instruction addu (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (signed-byte 16) fixup null) src1 src2))
+ (type (or tn (signed-byte 16) fixup null) src1 src2))
(:printer register ((op special-op) (funct #b100001)))
(:printer immediate ((op #b001001)))
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(setf src2 src1)
(setf src1 dst))
(emit-math-inst segment dst src1
- (if (integerp src2) (- src2) src2)
- #b100010 #b001000)))
+ (if (integerp src2) (- src2) src2)
+ #b100010 #b001000)))
(define-instruction subu (segment dst src1 &optional src2)
(:declare
(setf src2 src1)
(setf src1 dst))
(emit-math-inst segment dst src1
- (if (integerp src2) (- src2) src2)
- #b100011 #b001001 t)))
+ (if (integerp src2) (- src2) src2)
+ #b100011 #b001001 t)))
(define-instruction and (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (unsigned-byte 16) null) src1 src2))
+ (type (or tn (unsigned-byte 16) null) src1 src2))
(:printer register ((op special-op) (funct #b100100)))
(:printer immediate ((op #b001100) (immediate nil :sign-extend nil)))
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(define-instruction or (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (unsigned-byte 16) null) src1 src2))
+ (type (or tn (unsigned-byte 16) null) src1 src2))
(:printer register ((op special-op) (funct #b100101)))
(:printer immediate ((op #b001101)))
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(define-instruction xor (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (unsigned-byte 16) null) src1 src2))
+ (type (or tn (unsigned-byte 16) null) src1 src2))
(:printer register ((op special-op) (funct #b100110)))
(:printer immediate ((op #b001110)))
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(define-instruction slt (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (signed-byte 16) null) src1 src2))
+ (type (or tn (signed-byte 16) null) src1 src2))
(:printer register ((op special-op) (funct #b101010)))
(:printer immediate ((op #b001010)))
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(define-instruction sltu (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (signed-byte 16) null) src1 src2))
+ (type (or tn (signed-byte 16) null) src1 src2))
(:printer register ((op special-op) (funct #b101011)))
(:printer immediate ((op #b001011)))
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(:delay 1)
(:emitter
(emit-register-inst segment special-op (reg-tn-encoding src1)
- (reg-tn-encoding src2) 0 0 #b011010)))
+ (reg-tn-encoding src2) 0 0 #b011010)))
(define-instruction divu (segment src1 src2)
(:declare (type tn src1 src2))
(:printer register ((op special-op) (rd 0) (funct #b011011))
- divmul-printer)
+ divmul-printer)
(:dependencies (reads src1) (reads src2) (writes :hi-reg) (writes :low-reg))
(:delay 1)
(:emitter
(emit-register-inst segment special-op (reg-tn-encoding src1)
- (reg-tn-encoding src2) 0 0 #b011011)))
+ (reg-tn-encoding src2) 0 0 #b011011)))
(define-instruction mult (segment src1 src2)
(:declare (type tn src1 src2))
(:delay 1)
(:emitter
(emit-register-inst segment special-op (reg-tn-encoding src1)
- (reg-tn-encoding src2) 0 0 #b011000)))
+ (reg-tn-encoding src2) 0 0 #b011000)))
(define-instruction multu (segment src1 src2)
(:declare (type tn src1 src2))
(:delay 1)
(:emitter
(emit-register-inst segment special-op (reg-tn-encoding src1)
- (reg-tn-encoding src2) 0 0 #b011001)))
+ (reg-tn-encoding src2) 0 0 #b011001)))
(defun emit-shift-inst (segment opcode dst src1 src2)
(unless src2
(etypecase src2
(tn
(emit-register-inst segment special-op (reg-tn-encoding src2)
- (reg-tn-encoding src1) (reg-tn-encoding dst)
- 0 (logior #b000100 opcode)))
+ (reg-tn-encoding src1) (reg-tn-encoding dst)
+ 0 (logior #b000100 opcode)))
((unsigned-byte 5)
(emit-register-inst segment special-op 0 (reg-tn-encoding src1)
- (reg-tn-encoding dst) src2 opcode))))
+ (reg-tn-encoding dst) src2 opcode))))
(defconstant-eqx shift-printer
'(:name :tab
(define-instruction sll (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (unsigned-byte 5) null) src1 src2))
+ (type (or tn (unsigned-byte 5) null) src1 src2))
(:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000000))
- shift-printer)
+ shift-printer)
(:printer register ((op special-op) (funct #b000100)) shift-printer)
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(:delay 0)
(define-instruction sra (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (unsigned-byte 5) null) src1 src2))
+ (type (or tn (unsigned-byte 5) null) src1 src2))
(:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000011))
- shift-printer)
+ shift-printer)
(:printer register ((op special-op) (funct #b000111)) shift-printer)
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(:delay 0)
(define-instruction srl (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn (unsigned-byte 5) null) src1 src2))
+ (type (or tn (unsigned-byte 5) null) src1 src2))
(:printer register ((op special-op) (rs 0) (shamt nil) (funct #b000010))
- shift-printer)
+ shift-printer)
(:printer register ((op special-op) (funct #b000110)) shift-printer)
(:dependencies (reads src1) (if src2 (reads src2) (reads dst)) (writes dst))
(:delay 0)
(define-instruction float-op (segment operation format dst src1 src2)
(:declare (type float-operation operation)
- (type float-format format)
- (type tn dst src1 src2))
+ (type float-format format)
+ (type tn dst src1 src2))
(:printer float-op ())
(:dependencies (reads src1) (reads src2) (writes dst))
(:delay 0)
(:emitter
(emit-float-inst segment cop1-op 1 (float-format-value format)
- (fp-reg-tn-encoding src2) (fp-reg-tn-encoding src1)
- (fp-reg-tn-encoding dst) (float-operation operation))))
+ (fp-reg-tn-encoding src2) (fp-reg-tn-encoding src1)
+ (fp-reg-tn-encoding dst) (float-operation operation))))
(defconstant-eqx float-unop-printer
`(:name ,@float-fmt-printer :tab fd (:unless (:same-as fd) ", " fs))
(:delay 0)
(:emitter
(emit-float-inst segment cop1-op 1 (float-format-value format)
- 0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
- #b000101)))
+ 0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
+ #b000101)))
(define-instruction fneg (segment format dst &optional (src dst))
(:declare (type float-format format) (type tn dst src))
(:delay 0)
(:emitter
(emit-float-inst segment cop1-op 1 (float-format-value format)
- 0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
- #b000111)))
-
+ 0 (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
+ #b000111)))
+
(define-instruction fcvt (segment format1 format2 dst src)
(:declare (type float-format format1 format2) (type tn dst src))
(:printer float-aux ((funct #b10) (sub-funct nil :type 'float-format))
- `(:name "." sub-funct "." format :tab fd ", " fs))
+ `(:name "." sub-funct "." format :tab fd ", " fs))
(:dependencies (reads src) (writes dst))
(:delay 0)
(:emitter
(emit-float-inst segment cop1-op 1 (float-format-value format2) 0
- (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
- (logior #b100000 (float-format-value format1)))))
+ (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
+ (logior #b100000 (float-format-value format1)))))
(define-instruction fcmp (segment operation format fs ft)
(:declare (type compare-kind operation)
- (type float-format format)
- (type tn fs ft))
+ (type float-format format)
+ (type tn fs ft))
(:printer float-aux ((fd 0) (funct #b11) (sub-funct nil :type 'compare-kind))
- `(:name "-" sub-funct "." format :tab fs ", " ft))
+ `(:name "-" sub-funct "." format :tab fs ", " ft))
(:dependencies (reads fs) (reads ft) (writes :float-status))
(:delay 1)
(:emitter
- (emit-float-inst segment cop1-op 1 (float-format-value format)
- (fp-reg-tn-encoding ft) (fp-reg-tn-encoding fs) 0
- (logior #b110000 (compare-kind operation)))))
+ (emit-float-inst segment cop1-op 1 (float-format-value format)
+ (fp-reg-tn-encoding ft) (fp-reg-tn-encoding fs) 0
+ (logior #b110000 (compare-kind operation)))))
\f
;;;; Branch/Jump instructions.
(emit-chooser
segment 20 2
#'(lambda (segment posn magic-value)
- (declare (ignore magic-value))
+ (declare (ignore magic-value))
(let ((delta (ash (- (label-position target) (+ posn 4)) -2)))
- (when (typep delta '(signed-byte 16))
- (emit-back-patch segment 4
- #'(lambda (segment posn)
- (emit-immediate-inst segment
- opcode
- (if (fixnump r1)
- r1
- (reg-tn-encoding r1))
- (if (fixnump r2)
- r2
- (reg-tn-encoding r2))
- (ash (- (label-position target)
- (+ posn 4))
- -2))))
- t)))
+ (when (typep delta '(signed-byte 16))
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (emit-immediate-inst segment
+ opcode
+ (if (fixnump r1)
+ r1
+ (reg-tn-encoding r1))
+ (if (fixnump r2)
+ r2
+ (reg-tn-encoding r2))
+ (ash (- (label-position target)
+ (+ posn 4))
+ -2))))
+ t)))
#'(lambda (segment posn)
- (declare (ignore posn))
- (let ((linked))
- ;; invert branch condition
- (if (or (= opcode bcond-op) (= opcode cop1-op))
- (setf r2 (logxor r2 #b00001))
- (setf opcode (logxor opcode #b00001)))
- ;; check link flag
- (if (= opcode bcond-op)
- (if (logand r2 #b10000)
- (progn (setf r2 (logand r2 #b01111))
- (setf linked t))))
- (emit-immediate-inst segment
- opcode
- (if (fixnump r1) r1 (reg-tn-encoding r1))
- (if (fixnump r2) r2 (reg-tn-encoding r2))
- 4)
- (emit-nop segment)
- (emit-back-patch segment 8
- #'(lambda (segment posn)
- (declare (ignore posn))
- (emit-immediate-inst segment #b001111 0
- (reg-tn-encoding lip-tn)
- (ldb (byte 16 16)
- (label-position target)))
- (emit-immediate-inst segment #b001101 0
- (reg-tn-encoding lip-tn)
- (ldb (byte 16 0)
- (label-position target)))))
- (emit-register-inst segment special-op (reg-tn-encoding lip-tn)
- 0 (if linked 31 0) 0
- (if linked #b001001 #b001000))))))
+ (declare (ignore posn))
+ (let ((linked))
+ ;; invert branch condition
+ (if (or (= opcode bcond-op) (= opcode cop1-op))
+ (setf r2 (logxor r2 #b00001))
+ (setf opcode (logxor opcode #b00001)))
+ ;; check link flag
+ (if (= opcode bcond-op)
+ (if (logand r2 #b10000)
+ (progn (setf r2 (logand r2 #b01111))
+ (setf linked t))))
+ (emit-immediate-inst segment
+ opcode
+ (if (fixnump r1) r1 (reg-tn-encoding r1))
+ (if (fixnump r2) r2 (reg-tn-encoding r2))
+ 4)
+ (emit-nop segment)
+ (emit-back-patch segment 8
+ #'(lambda (segment posn)
+ (declare (ignore posn))
+ (emit-immediate-inst segment #b001111 0
+ (reg-tn-encoding lip-tn)
+ (ldb (byte 16 16)
+ (label-position target)))
+ (emit-immediate-inst segment #b001101 0
+ (reg-tn-encoding lip-tn)
+ (ldb (byte 16 0)
+ (label-position target)))))
+ (emit-register-inst segment special-op (reg-tn-encoding lip-tn)
+ 0 (if linked 31 0) 0
+ (if linked #b001001 #b001000))))))
(define-instruction b (segment target)
(:declare (type label target))
(:printer immediate ((op #b000100) (rs 0) (rt 0)
- (immediate nil :type 'relative-label))
- '(:name :tab immediate))
+ (immediate nil :type 'relative-label))
+ '(:name :tab immediate))
(:attributes branch)
(:delay 1)
(:emitter
(define-instruction bal (segment target)
(:declare (type label target))
(:printer immediate ((op bcond-op) (rs 0) (rt #b01001)
- (immediate nil :type 'relative-label))
- '(:name :tab immediate))
+ (immediate nil :type 'relative-label))
+ '(:name :tab immediate))
(:attributes branch)
(:dependencies (writes :r31))
(:delay 1)
(define-instruction beq (segment r1 r2-or-target &optional target)
(:declare (type tn r1)
- (type (or tn fixnum label) r2-or-target)
- (type (or label null) target))
+ (type (or tn fixnum label) r2-or-target)
+ (type (or label null) target))
(:printer immediate ((op #b000100) (immediate nil :type 'relative-label)))
(:attributes branch)
(:dependencies (reads r1) (if target (reads r2-or-target)))
(define-instruction bne (segment r1 r2-or-target &optional target)
(:declare (type tn r1)
- (type (or tn fixnum label) r2-or-target)
- (type (or label null) target))
+ (type (or tn fixnum label) r2-or-target)
+ (type (or label null) target))
(:printer immediate ((op #b000101) (immediate nil :type 'relative-label)))
(:attributes branch)
(:dependencies (reads r1) (if target (reads r2-or-target)))
(:declare (type label target) (type tn reg))
(:printer
immediate ((op #b000110) (rt 0) (immediate nil :type 'relative-label))
- cond-branch-printer)
+ cond-branch-printer)
(:attributes branch)
(:dependencies (reads reg))
(:delay 1)
(:declare (type label target) (type tn reg))
(:printer
immediate ((op #b000111) (rt 0) (immediate nil :type 'relative-label))
- cond-branch-printer)
+ cond-branch-printer)
(:attributes branch)
(:dependencies (reads reg))
(:delay 1)
(:declare (type label target) (type tn reg))
(:printer
immediate ((op bcond-op) (rt 0) (immediate nil :type 'relative-label))
- cond-branch-printer)
+ cond-branch-printer)
(:attributes branch)
(:dependencies (reads reg))
(:delay 1)
(:declare (type label target) (type tn reg))
(:printer
immediate ((op bcond-op) (rt 1) (immediate nil :type 'relative-label))
- cond-branch-printer)
+ cond-branch-printer)
(:attributes branch)
(:dependencies (reads reg))
(:delay 1)
(:declare (type label target) (type tn reg))
(:printer
immediate ((op bcond-op) (rt #b01000) (immediate nil :type 'relative-label))
- cond-branch-printer)
+ cond-branch-printer)
(:attributes branch)
(:dependencies (reads reg) (writes :r31))
(:delay 1)
(:declare (type label target) (type tn reg))
(:printer
immediate ((op bcond-op) (rt #b01001) (immediate nil :type 'relative-label))
- cond-branch-printer)
+ cond-branch-printer)
(:attributes branch)
(:delay 1)
(:dependencies (reads reg) (writes :r31))
(define-instruction j (segment target)
(:declare (type (or tn fixup) target))
(:printer register ((op special-op) (rt 0) (rd 0) (funct #b001000))
- j-printer)
+ j-printer)
(:printer jump ((op #b000010)) j-printer)
(:attributes branch)
(:dependencies (reads target))
(etypecase target
(tn
(emit-register-inst segment special-op (reg-tn-encoding target)
- 0 0 0 #b001000))
+ 0 0 0 #b001000))
(fixup
(note-fixup segment :jump target)
(emit-jump-inst segment #b000010 0)))))
(define-instruction jal (segment reg-or-target &optional target)
(:declare (type (or null tn fixup) target)
- (type (or tn fixup (integer -16 31)) reg-or-target))
+ (type (or tn fixup (integer -16 31)) reg-or-target))
(:printer register ((op special-op) (rt 0) (funct #b001001)) j-printer)
(:printer jump ((op #b000011)) j-printer)
(:attributes branch)
(etypecase target
(tn
(emit-register-inst segment special-op (reg-tn-encoding target) 0
- reg-or-target 0 #b001001))
+ reg-or-target 0 #b001001))
(fixup
(note-fixup segment :jump target)
(emit-jump-inst segment #b000011 0)))))
(define-instruction bc1f (segment target)
(:declare (type label target))
(:printer coproc-branch ((op cop1-op) (funct #x100)
- (offset nil :type 'relative-label)))
+ (offset nil :type 'relative-label)))
(:attributes branch)
(:dependencies (reads :float-status))
(:delay 1)
(define-instruction bc1t (segment target)
(:declare (type label target))
(:printer coproc-branch ((op cop1-op) (funct #x101)
- (offset nil :type 'relative-label)))
+ (offset nil :type 'relative-label)))
(:attributes branch)
(:dependencies (reads :float-status))
(:delay 1)
(define-instruction lui (segment reg value)
(:declare (type tn reg)
- (type (or fixup (signed-byte 16) (unsigned-byte 16)) value))
+ (type (or fixup (signed-byte 16) (unsigned-byte 16)) value))
(:printer immediate ((op #b001111)
- (immediate nil :sign-extend nil :printer "#x~4,'0X")))
+ (immediate nil :sign-extend nil :printer "#x~4,'0X")))
(:dependencies (writes reg))
(:delay 0)
(:emitter
(define-instruction mfhi (segment reg)
(:declare (type tn reg))
(:printer register ((op special-op) (rs 0) (rt 0) (funct #b010000))
- mvsreg-printer)
+ mvsreg-printer)
(:dependencies (reads :hi-reg) (writes reg))
(:delay 2)
(:emitter
(emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
- #b010000)))
+ #b010000)))
(define-instruction mthi (segment reg)
(:declare (type tn reg))
(:printer register ((op special-op) (rs 0) (rt 0) (funct #b010001))
- mvsreg-printer)
+ mvsreg-printer)
(:dependencies (reads reg) (writes :hi-reg))
(:delay 0)
(:emitter
(emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
- #b010001)))
+ #b010001)))
(define-instruction mflo (segment reg)
(:declare (type tn reg))
(:printer register ((op special-op) (rs 0) (rt 0) (funct #b010010))
- mvsreg-printer)
+ mvsreg-printer)
(:dependencies (reads :low-reg) (writes reg))
(:delay 2)
(:emitter
(emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
- #b010010)))
+ #b010010)))
(define-instruction mtlo (segment reg)
(:declare (type tn reg))
(:printer register ((op special-op) (rs 0) (rt 0) (funct #b010011))
- mvsreg-printer)
+ mvsreg-printer)
(:dependencies (reads reg) (writes :low-reg))
(:delay 0)
(:emitter
(emit-register-inst segment special-op 0 0 (reg-tn-encoding reg) 0
- #b010011)))
+ #b010011)))
(define-instruction move (segment dst src)
(:declare (type tn dst src))
(:printer register ((op special-op) (rt 0) (funct #b100001))
- '(:name :tab rd ", " rs))
+ '(:name :tab rd ", " rs))
(:attributes flushable)
(:dependencies (reads src) (writes dst))
(:delay 0)
(:emitter
(emit-register-inst segment special-op (reg-tn-encoding src) 0
- (reg-tn-encoding dst) 0 #b100001)))
+ (reg-tn-encoding dst) 0 #b100001)))
(define-instruction fmove (segment format dst src)
(:declare (type float-format format) (type tn dst src))
(:delay 0)
(:emitter
(emit-float-inst segment cop1-op 1 (float-format-value format) 0
- (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
- #b000110)))
+ (fp-reg-tn-encoding src) (fp-reg-tn-encoding dst)
+ #b000110)))
(defun %li (reg value)
(etypecase value
(fixup
(inst lui reg value)
(inst addu reg value))))
-
+
(define-instruction-macro li (reg value)
`(%li ,reg ,value))
(:delay 1)
(:emitter
(emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
- (fp-reg-tn-encoding to) 0 0)))
+ (fp-reg-tn-encoding to) 0 0)))
(define-instruction mtc1-odd (segment to from)
(:declare (type tn to from))
(:delay 1)
(:emitter
(emit-register-inst segment cop1-op #b00100 (reg-tn-encoding from)
- (1+ (fp-reg-tn-encoding to)) 0 0)))
+ (1+ (fp-reg-tn-encoding to)) 0 0)))
(define-instruction mfc1 (segment to from)
(:declare (type tn to from))
(:printer register ((op cop1-op) (rs 0) (rd nil :type 'fp-reg) (funct 0))
- sub-op-printer)
+ sub-op-printer)
(:dependencies (reads from) (writes to))
(:delay 1)
(:emitter
(emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
- (fp-reg-tn-encoding from) 0 0)))
+ (fp-reg-tn-encoding from) 0 0)))
(define-instruction mfc1-odd (segment to from)
(:declare (type tn to from))
(:delay 1)
(:emitter
(emit-register-inst segment cop1-op #b00000 (reg-tn-encoding to)
- (1+ (fp-reg-tn-encoding from)) 0 0)))
+ (1+ (fp-reg-tn-encoding from)) 0 0)))
(define-instruction mfc1-odd2 (segment to from)
(:declare (type tn to from))
(:delay 1)
(:emitter
(emit-register-inst segment cop1-op #b00000 (1+ (reg-tn-encoding to))
- (fp-reg-tn-encoding from) 0 0)))
+ (fp-reg-tn-encoding from) 0 0)))
(define-instruction mfc1-odd3 (segment to from)
(:declare (type tn to from))
(:delay 1)
(:emitter
(emit-register-inst segment cop1-op #b00000 (1+ (reg-tn-encoding to))
- (1+ (fp-reg-tn-encoding from)) 0 0)))
+ (1+ (fp-reg-tn-encoding from)) 0 0)))
(define-instruction cfc1 (segment reg cr)
(:declare (type tn reg) (type (unsigned-byte 5) cr))
(:printer register ((op cop1-op) (rs #b00010) (rd nil :type 'control-reg)
- (funct 0)) sub-op-printer)
+ (funct 0)) sub-op-printer)
(:dependencies (reads :ctrl-stat-reg) (writes reg))
(:delay 1)
(:emitter
(emit-register-inst segment cop1-op #b00010 (reg-tn-encoding reg)
- cr 0 0)))
+ cr 0 0)))
(define-instruction ctc1 (segment reg cr)
(:declare (type tn reg) (type (unsigned-byte 5) cr))
(:printer register ((op cop1-op) (rs #b00110) (rd nil :type 'control-reg)
- (funct 0)) sub-op-printer)
+ (funct 0)) sub-op-printer)
(:dependencies (reads reg) (writes :ctrl-stat-reg))
(:delay 1)
(:emitter
(emit-register-inst segment cop1-op #b00110 (reg-tn-encoding reg)
- cr 0 0)))
+ cr 0 0)))
\f
(define-instruction break (segment code &optional (subcode 0))
(:declare (type (unsigned-byte 10) code subcode))
(:printer break ((op special-op) (funct #b001101))
- '(:name :tab code (:unless (:constant 0) subcode))
- :control #'break-control )
+ '(:name :tab code (:unless (:constant 0) subcode))
+ :control #'break-control )
:pinned
(:cost 0)
(:delay 0)
(define-instruction syscall (segment)
(:printer register ((op special-op) (rd 0) (rt 0) (rs 0) (funct #b001100))
- '(:name))
+ '(:name))
:pinned
(:delay 0)
(:emitter
segment 4
#'(lambda (segment posn)
(emit-word segment
- (logior type
- (ash (+ posn (component-header-length))
- (- n-widetag-bits word-shift)))))))
+ (logior type
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift)))))))
(define-instruction fun-header-word (segment)
:pinned
segment 12 3
#'(lambda (segment posn delta-if-after)
(let ((delta (funcall calc label posn delta-if-after)))
- (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
- (emit-back-patch segment 4
- #'(lambda (segment posn)
- (assemble (segment vop)
- (inst addu dst src
- (funcall calc label posn 0)))))
- t)))
+ (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (assemble (segment vop)
+ (inst addu dst src
+ (funcall calc label posn 0)))))
+ t)))
#'(lambda (segment posn)
(let ((delta (funcall calc label posn 0)))
- (assemble (segment vop)
- (inst lui temp (ldb (byte 16 16) delta))
- (inst or temp (ldb (byte 16 0) delta))
- (inst addu dst src temp))))))
+ (assemble (segment vop)
+ (inst lui temp (ldb (byte 16 16) delta))
+ (inst or temp (ldb (byte 16 0) delta))
+ (inst addu dst src temp))))))
;; code = fn - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-fn (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (- other-pointer-lowtag
- (label-position label posn delta-if-after)
- (component-header-length))))))
+ #'(lambda (label posn delta-if-after)
+ (- other-pointer-lowtag
+ (label-position label posn delta-if-after)
+ (component-header-length))))))
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
;; = lra - (header + label-offset)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (- (+ (label-position label posn delta-if-after)
- (component-header-length)))))))
+ #'(lambda (label posn delta-if-after)
+ (- (+ (label-position label posn delta-if-after)
+ (component-header-length)))))))
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
(define-instruction compute-lra-from-code (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (+ (label-position label posn delta-if-after)
- (component-header-length))))))
+ #'(lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length))))))
\f
;;;; Loads and Stores
(note-fixup segment :addi index)
(setf index 0))
(emit-immediate-inst segment opcode (reg-tn-encoding reg)
- (+ (reg-tn-encoding base) oddhack) index))
+ (+ (reg-tn-encoding base) oddhack) index))
(defconstant-eqx load-store-printer
'(:name :tab
(define-instruction lb (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b100000)) load-store-printer)
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
(define-instruction lh (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b100001)) load-store-printer)
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
(define-instruction lwl (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b100010)) load-store-printer)
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
(define-instruction lw (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b100011)) load-store-printer)
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
;; next is just for ease of coding double-in-int c-call convention
(define-instruction lw-odd (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
(:emitter
(define-instruction lbu (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b100100)) load-store-printer)
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
(define-instruction lhu (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b100101)) load-store-printer)
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
(define-instruction lwr (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b100110)) load-store-printer)
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
(define-instruction sb (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b101000)) load-store-printer)
(:dependencies (reads base) (reads reg) (writes :memory))
(:delay 0)
(define-instruction sh (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b101001)) load-store-printer)
(:dependencies (reads base) (reads reg) (writes :memory))
(:delay 0)
(define-instruction swl (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b101010)) load-store-printer)
(:dependencies (reads base) (reads reg) (writes :memory))
(:delay 0)
(define-instruction sw (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b101011)) load-store-printer)
(:dependencies (reads base) (reads reg) (writes :memory))
(:delay 0)
(define-instruction swr (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b101110)) load-store-printer)
(:dependencies (reads base) (reads reg) (writes :memory))
(:delay 0)
(note-fixup segment :addi index)
(setf index 0))
(emit-immediate-inst segment opcode (reg-tn-encoding base)
- (+ (fp-reg-tn-encoding reg) odd) index))
+ (+ (fp-reg-tn-encoding reg) odd) index))
(define-instruction lwc1 (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b110001) (rt nil :type 'fp-reg)) load-store-printer)
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
(define-instruction lwc1-odd (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:dependencies (reads base) (reads :memory) (writes reg))
(:delay 1)
(:emitter
(define-instruction swc1 (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:printer immediate ((op #b111001) (rt nil :type 'fp-reg)) load-store-printer)
(:dependencies (reads base) (reads reg) (writes :memory))
(:delay 0)
(define-instruction swc1-odd (segment reg base &optional (index 0))
(:declare (type tn reg base)
- (type (or (signed-byte 16) fixup) index))
+ (type (or (signed-byte 16) fixup) index))
(:dependencies (reads base) (reads reg) (writes :memory))
(:delay 0)
(:emitter
(defmacro expand (expr)
(let ((gensym (gensym)))
`(macrolet
- ((,gensym ()
- ,expr))
+ ((,gensym ()
+ ,expr))
(,gensym))))
\f
"Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
is nil)."
(once-only ((n-dst dst)
- (n-src src))
+ (n-src src))
`(if (location= ,n-dst ,n-src)
- (when ,always-emit-code-p
- (inst nop))
- (inst move ,n-dst ,n-src))))
+ (when ,always-emit-code-p
+ (inst nop))
+ (inst move ,n-dst ,n-src))))
(defmacro def-mem-op (op inst shift load)
`(defmacro ,op (object base &optional (offset 0) (lowtag 0))
`(progn
- (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
- ,,@(when load '('(inst nop))))))
-;;;
+ (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
+ ,,@(when load '('(inst nop))))))
+;;;
(def-mem-op loadw lw word-shift t)
(def-mem-op storew sw word-shift nil)
(defmacro load-symbol-value (reg symbol)
`(progn
(inst lw ,reg null-tn
- (+ (static-symbol-offset ',symbol)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag)))
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag)))
(inst nop)))
(defmacro store-symbol-value (reg symbol)
`(inst sw ,reg null-tn
- (+ (static-symbol-offset ',symbol)
- (ash symbol-value-slot word-shift)
- (- other-pointer-lowtag))))
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-lowtag))))
(defmacro load-type (target source &optional (offset 0))
"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 lbu ,n-target ,n-source ,n-offset))
;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions.
+;;; return instructions.
(defmacro lisp-jump (function lip)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
(inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag))
+ fun-pointer-lowtag))
(inst j ,lip)
(move code-tn ,function t)))
"Return to RETURN-PC. LIP is an interior-reg temporary."
`(progn
(inst addu ,lip ,return-pc
- (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
+ (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
(inst j ,lip)
,(if frob-code
- `(move code-tn ,return-pc t)
- '(inst nop))))
+ `(move code-tn ,return-pc t)
+ '(inst nop))))
(defmacro emit-return-pc (label)
;;; Move a stack TN to a register and vice-versa.
(defmacro load-stack-tn (reg stack)
`(let ((reg ,reg)
- (stack ,stack))
+ (stack ,stack))
(let ((offset (tn-offset stack)))
(sc-case stack
- ((control-stack)
- (loadw reg cfp-tn offset))))))
+ ((control-stack)
+ (loadw reg cfp-tn offset))))))
(defmacro store-stack-tn (stack reg)
`(let ((stack ,stack)
- (reg ,reg))
+ (reg ,reg))
(let ((offset (tn-offset stack)))
(sc-case stack
- ((control-stack)
- (storew reg cfp-tn offset))))))
+ ((control-stack)
+ (storew reg cfp-tn offset))))))
(defmacro maybe-load-stack-tn (reg reg-or-stack)
"Move the TN Reg-Or-Stack into Reg if it isn't already there."
(once-only ((n-reg reg)
- (n-stack reg-or-stack))
+ (n-stack reg-or-stack))
`(sc-case ,n-reg
((any-reg descriptor-reg)
- (sc-case ,n-stack
- ((any-reg descriptor-reg)
- (move ,n-reg ,n-stack))
- ((control-stack)
- (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+ (sc-case ,n-stack
+ ((any-reg descriptor-reg)
+ (move ,n-reg ,n-stack))
+ ((control-stack)
+ (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
\f
;;;; Storage allocation:
(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
- &body body)
+ &body body)
"Do stuff to allocate an other-pointer object of fixed Size with a single
word header having the specified Type-Code. The result is placed in
Result-TN, Flag-Tn must be wired to NL4-OFFSET, and Temp-TN is a non-
(ecase condition
(:eq
(if not-p
- (inst bne x y target)
- (inst beq x y target)))
+ (inst bne x y target)
+ (inst beq x y target)))
(:lt
(ecase flavor
(:unsigned
- (inst sltu temp x y))
+ (inst sltu temp x y))
(:signed
- (inst slt temp x y)))
+ (inst slt temp x y)))
(if not-p
- (inst beq temp zero-tn target)
- (inst bne temp zero-tn target)))
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn target)))
(:gt
(ecase flavor
(:unsigned
- (inst sltu temp y x))
+ (inst sltu temp y x))
(:signed
- (inst slt temp y x)))
+ (inst slt temp y x)))
(if not-p
- (inst beq temp zero-tn target)
- (inst bne temp zero-tn target))))
+ (inst beq temp zero-tn target)
+ (inst bne temp zero-tn target))))
(inst nop))
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
`((let ((vop ,vop))
- (when vop
- (note-this-location vop :internal-error)))
- (inst break ,kind)
- (with-adjustable-vector (,vector)
- (write-var-integer (error-number-or-lose ',code) ,vector)
- ,@(mapcar #'(lambda (tn)
- `(let ((tn ,tn))
- (write-var-integer (make-sc-offset (sc-number
- (tn-sc tn))
- (tn-offset tn))
- ,vector)))
- values)
- (inst byte (length ,vector))
- (dotimes (i (length ,vector))
- (inst byte (aref ,vector i))))
- (align word-shift)))))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst break ,kind)
+ (with-adjustable-vector (,vector)
+ (write-var-integer (error-number-or-lose ',code) ,vector)
+ ,@(mapcar #'(lambda (tn)
+ `(let ((tn ,tn))
+ (write-var-integer (make-sc-offset (sc-number
+ (tn-sc tn))
+ (tn-offset tn))
+ ,vector)))
+ values)
+ (inst byte (length ,vector))
+ (dotimes (i (length ,vector))
+ (inst byte (aref ,vector i))))
+ (align word-shift)))))
(defmacro error-call (vop error-code &rest values)
"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 cerror-call (vop label error-code &rest values)
`(let ((,continue (gen-label)))
(emit-label ,continue)
(assemble (*elsewhere*)
- (let ((,error (gen-label)))
- (emit-label ,error)
- (cerror-call ,vop ,continue ,error-code ,@values)
- ,error)))))
+ (let ((,error (gen-label)))
+ (emit-label ,error)
+ (cerror-call ,vop ,continue ,error-code ,@values)
+ ,error)))))
\f
;;;; PSEUDO-ATOMIC
,@forms
(without-scheduling ()
(let ((label (gen-label)))
- (inst bgez ,flag-tn label)
- (inst addu alloc-tn (1- ,extra))
- (inst break 16)
- (emit-label label)))))
+ (inst bgez ,flag-tn label)
+ (inst addu alloc-tn (1- ,extra))
+ (inst break 16)
+ (emit-label label)))))
\f
;;;; memory accessor vop generators
(deftype load/store-index (scale lowtag min-offset
- &optional (max-offset min-offset))
+ &optional (max-offset min-offset))
`(integer ,(- (truncate (+ (ash 1 16)
- (* min-offset n-word-bytes)
- (- lowtag))
- scale))
- ,(truncate (- (+ (1- (ash 1 16)) lowtag)
- (* max-offset n-word-bytes))
- scale)))
+ (* min-offset n-word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+ (* max-offset n-word-bytes))
+ scale)))
(defmacro define-full-reffer (name type offset lowtag scs el-type
- &optional translate)
+ &optional translate)
`(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)
(:temporary (:scs (interior-reg)) lip)
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 5
- (inst add lip object index)
- (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
- (inst nop)))
+ (inst add lip object index)
+ (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
+ (inst nop)))
(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 4
- (inst lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
- (inst nop)))))
+ (inst lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
+ (inst nop)))))
(defmacro define-full-setter (name type offset lowtag scs el-type
- &optional translate)
+ &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)
(:temporary (:scs (interior-reg)) lip)
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 2
- (inst add lip object index)
- (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
- (move result value)))
+ (inst add lip object index)
+ (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
+ (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))
+ (value :scs ,scs))
(: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 1
- (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
- (move result value)))))
+ (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
+ (move result value)))))
(defmacro define-partial-reffer (name type size signed offset lowtag scs
- el-type &optional translate)
+ el-type &optional translate)
(let ((scale (ecase size (:byte 1) (:short 2))))
`(progn
(define-vop (,name)
- ,@(when translate
- `((:translate ,translate)))
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg)))
- (:arg-types ,type positive-fixnum)
- (:results (value :scs ,scs))
- (:result-types ,el-type)
- (:temporary (:scs (interior-reg)) lip)
- (:generator 5
- (inst addu lip object index)
- ,@(when (eq size :short)
- '((inst addu lip index)))
- (inst ,(ecase size
- (:byte (if signed 'lb 'lbu))
- (:short (if signed 'lh 'lhu)))
- value lip (- (* ,offset n-word-bytes) ,lowtag))
- (inst nop)))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 5
+ (inst addu lip object index)
+ ,@(when (eq size :short)
+ '((inst addu lip index)))
+ (inst ,(ecase size
+ (:byte (if signed 'lb 'lbu))
+ (:short (if signed 'lh 'lhu)))
+ value lip (- (* ,offset n-word-bytes) ,lowtag))
+ (inst nop)))
(define-vop (,(symbolicate name "-C"))
- ,@(when translate
- `((:translate ,translate)))
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg)))
- (:info index)
- (:arg-types ,type
- (:constant (load/store-index ,scale
- ,(eval lowtag)
- ,(eval offset))))
- (:results (value :scs ,scs))
- (:result-types ,el-type)
- (:generator 4
- (inst ,(ecase size
- (:byte (if signed 'lb 'lbu))
- (:short (if signed 'lh 'lhu)))
- value object
- (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
- (inst nop))))))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset))))
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 4
+ (inst ,(ecase size
+ (:byte (if signed 'lb 'lbu))
+ (:short (if signed 'lh 'lhu)))
+ value object
+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
+ (inst nop))))))
(defmacro define-partial-setter (name type size offset lowtag scs el-type
- &optional translate)
+ &optional translate)
(let ((scale (ecase size (:byte 1) (:short 2))))
`(progn
(define-vop (,name)
- ,@(when translate
- `((:translate ,translate)))
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (index :scs (unsigned-reg))
- (value :scs ,scs :target result))
- (:arg-types ,type positive-fixnum ,el-type)
- (:temporary (:scs (interior-reg)) lip)
- (:results (result :scs ,scs))
- (:result-types ,el-type)
- (:generator 5
- (inst addu lip object index)
- ,@(when (eq size :short)
- '((inst addu lip index)))
- (inst ,(ecase size (:byte 'sb) (:short 'sh))
- value lip (- (* ,offset n-word-bytes) ,lowtag))
- (move result value)))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg))
+ (value :scs ,scs :target result))
+ (:arg-types ,type positive-fixnum ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst addu lip object index)
+ ,@(when (eq size :short)
+ '((inst addu lip index)))
+ (inst ,(ecase size (:byte 'sb) (:short 'sh))
+ value lip (- (* ,offset n-word-bytes) ,lowtag))
+ (move result value)))
(define-vop (,(symbolicate name "-C"))
- ,@(when translate
- `((:translate ,translate)))
- (:policy :fast-safe)
- (:args (object :scs (descriptor-reg))
- (value :scs ,scs :target result))
- (:info index)
- (:arg-types ,type
- (:constant (load/store-index ,scale
- ,(eval lowtag)
- ,(eval offset)))
- ,el-type)
- (:results (result :scs ,scs))
- (:result-types ,el-type)
- (:generator 4
- (inst ,(ecase size (:byte 'sb) (:short 'sh))
- value object
- (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
- (move result value))))))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs ,scs :target result))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset)))
+ ,el-type)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 4
+ (inst ,(ecase size (:byte 'sb) (:short 'sh))
+ value object
+ (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
+ (move result value))))))
(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
garbage collection. This is currently implemented by disabling GC"
- (declare (ignore objects)) ;should we eval these for side-effect?
+ (declare (ignore objects)) ;should we eval these for side-effect?
`(without-gcing
,@body))
;;;
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg null zero)))
+ (value :scs (descriptor-reg any-reg null zero)))
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(load-symbol y val))
(character
(inst li y (logior (ash (char-code val) n-widetag-bits)
- character-widetag))))))
+ character-widetag))))))
(define-move-fun (load-number 1) (vop x y)
((zero immediate)
;;;
(define-vop (move)
(:args (x :target y
- :scs (any-reg descriptor-reg zero null)
- :load-if (not (location= x y))))
+ :scs (any-reg descriptor-reg zero null)
+ :load-if (not (location= x y))))
(:results (y :scs (any-reg descriptor-reg control-stack)
- :load-if (not (location= x y))))
+ :load-if (not (location= x y))))
(:effects)
(:affected)
(:generator 0
(unless (location= x y)
(sc-case y
- ((any-reg descriptor-reg)
- (inst move y x))
- (control-stack
- (store-stack-tn y x))))))
+ ((any-reg descriptor-reg)
+ (inst move y x))
+ (control-stack
+ (store-stack-tn y x))))))
(define-move-vop move :move
(any-reg descriptor-reg zero null)
;;;
(define-vop (move-arg)
(:args (x :target y
- :scs (any-reg descriptor-reg null zero))
- (fp :scs (any-reg)
- :load-if (not (sc-is y any-reg descriptor-reg))))
+ :scs (any-reg descriptor-reg null zero))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y any-reg descriptor-reg))))
(:results (y))
(:generator 0
(sc-case y
(:generator 18
(move x arg)
(let ((fixnum (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst sra temp x 29)
(inst beq temp fixnum)
(inst nor temp zero-tn)
(inst beq temp done)
(inst sll y x 2)
-
+
(with-fixed-allocation
- (y pa-flag temp bignum-widetag (1+ bignum-digits-offset))
- (storew x y bignum-digits-offset other-pointer-lowtag))
+ (y pa-flag temp bignum-widetag (1+ bignum-digits-offset))
+ (storew x y bignum-digits-offset other-pointer-lowtag))
(inst b done)
(inst nop)
-
+
(emit-label fixnum)
(inst sll y x 2)
(emit-label done))))
(inst srl temp x 29)
(inst beq temp done)
(inst sll y x 2)
-
+
(pseudo-atomic
(pa-flag :extra (pad-data-block (+ bignum-digits-offset 2)))
(inst or y alloc-tn other-pointer-lowtag)
;;;
(define-vop (word-move)
(:args (x :target y
- :scs (signed-reg unsigned-reg)
- :load-if (not (location= x y))))
+ :scs (signed-reg unsigned-reg)
+ :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))))
(:effects)
(:affected)
(:note "word integer move")
;;;
(define-vop (move-word-arg)
(:args (x :target y
- :scs (signed-reg unsigned-reg))
- (fp :scs (any-reg)
- :load-if (not (sc-is y sap-reg))))
+ :scs (signed-reg unsigned-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "word integer argument move")
(:generator 0
(define-vop (save-dynamic-state)
(:results (catch :scs (descriptor-reg))
- (nfp :scs (descriptor-reg))
- (nsp :scs (descriptor-reg)))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 13
(load-symbol-value catch *current-catch-block*)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (move nfp cur-nfp)))
+ (move nfp cur-nfp)))
(move nsp nsp-tn)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
- (nfp :scs (descriptor-reg))
- (nsp :scs (descriptor-reg)))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 10
(store-symbol-value catch *current-catch-block*)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (move cur-nfp nfp)))
+ (move cur-nfp nfp)))
(move nsp-tn nsp)))
(define-vop (current-stack-pointer)
;;;
(define-vop (make-catch-block)
(:args (tn)
- (tag :scs (any-reg descriptor-reg)))
+ (tag :scs (any-reg descriptor-reg)))
(:info entry-label)
(:results (block :scs (any-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(define-vop (nlx-entry)
(:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
- ; would be inserted before the LRA.
- (start)
- (count))
+ ; would be inserted before the LRA.
+ (start)
+ (count))
(:results (values :more t))
(:temporary (:scs (descriptor-reg)) move-temp)
(:info label nvals)
(emit-return-pc label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
- ((= nvals 1)
- (let ((no-values (gen-label)))
- (inst beq count zero-tn no-values)
- (move (tn-ref-tn values) null-tn t)
- (loadw (tn-ref-tn values) start)
- (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 beq count zero-tn default-lab)
- (inst addu count count (fixnumize -1))
- (sc-case tn
- ((descriptor-reg any-reg)
- (loadw tn start i))
- (control-stack
- (loadw move-temp start i)
- (store-stack-tn tn move-temp)))))
-
- (let ((defaulting-done (gen-label)))
-
- (emit-label defaulting-done)
-
- (assemble (*elsewhere*)
- (dolist (def (defaults))
- (emit-label (car def))
- (let ((tn (cdr def)))
- (sc-case tn
- ((descriptor-reg any-reg)
- (move tn null-tn))
- (control-stack
- (store-stack-tn tn null-tn)))))
- (inst b defaulting-done)
- (inst nop))))))
+ ((= nvals 1)
+ (let ((no-values (gen-label)))
+ (inst beq count zero-tn no-values)
+ (move (tn-ref-tn values) null-tn t)
+ (loadw (tn-ref-tn values) start)
+ (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 beq count zero-tn default-lab)
+ (inst addu count count (fixnumize -1))
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (loadw tn start i))
+ (control-stack
+ (loadw move-temp start i)
+ (store-stack-tn tn move-temp)))))
+
+ (let ((defaulting-done (gen-label)))
+
+ (emit-label defaulting-done)
+
+ (assemble (*elsewhere*)
+ (dolist (def (defaults))
+ (emit-label (car def))
+ (let ((tn (cdr def)))
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (move tn null-tn))
+ (control-stack
+ (store-stack-tn tn null-tn)))))
+ (inst b defaulting-done)
+ (inst nop))))))
(load-stack-tn csp-tn sp)))
(emit-return-pc label)
(note-this-location vop :non-local-entry)
(let ((loop (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
;; Copy args.
(load-stack-tn dst top)
;; Establish results.
(sc-case new-start
- (any-reg (move new-start dst))
- (control-stack (store-stack-tn new-start dst)))
+ (any-reg (move new-start dst))
+ (control-stack (store-stack-tn new-start dst)))
(inst beq num zero-tn done)
(inst nop)
(sc-case new-count
- (any-reg (move new-count num))
- (control-stack (store-stack-tn new-count num)))
+ (any-reg (move new-count num))
+ (control-stack (store-stack-tn new-count num)))
;; Copy stuff on stack.
(emit-label loop)
(defconstant-eqx float-traps-byte (byte 5 7) #'equalp)
(defconstant-eqx float-exceptions-byte (byte 5 12) #'equalp)
(defconstant-eqx float-condition-bit (ash 1 23) #'equalp)
-(def!constant float-fast-bit 0) ; No fast mode on PMAX.
+(def!constant float-fast-bit 0) ; No fast mode on PMAX.
\f
;;;; Description of the target address space.
;;; Where to put the different spaces.
-;;;
+;;;
(def!constant read-only-space-start #x01000000)
(def!constant read-only-space-end #x05000000)
*binding-stack-start*
*control-stack-start*
*control-stack-end*
-
+
;; Interrupt Handling
*free-interrupt-context-index*
sb!unix::*interrupts-enabled*
))
(defparameter *static-funs*
- '(sb!kernel:two-arg-+
- sb!kernel:two-arg--
- sb!kernel:two-arg-*
- sb!kernel:two-arg-/
- sb!kernel:two-arg-<
- sb!kernel:two-arg->
+ '(sb!kernel:two-arg-+
+ sb!kernel:two-arg--
+ sb!kernel:two-arg-*
+ sb!kernel:two-arg-/
+ sb!kernel:two-arg-<
+ sb!kernel:two-arg->
sb!kernel:two-arg-=
- sb!kernel:two-arg-<=
- sb!kernel:two-arg->=
- sb!kernel:two-arg-/=
- eql
+ sb!kernel:two-arg-<=
+ sb!kernel:two-arg->=
+ sb!kernel:two-arg-/=
+ eql
sb!kernel:%negate
- sb!kernel:two-arg-and
- sb!kernel:two-arg-ior
+ sb!kernel:two-arg-and
+ sb!kernel:two-arg-ior
sb!kernel:two-arg-xor
- length
- sb!kernel:two-arg-gcd
+ length
+ sb!kernel:two-arg-gcd
sb!kernel:two-arg-lcm))
(define-vop (if-eq)
(:args (x :scs (any-reg descriptor-reg zero null))
- (y :scs (any-reg descriptor-reg zero null)))
+ (y :scs (any-reg descriptor-reg zero null)))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:translate eq)
(:generator 3
(if not-p
- (inst bne x y target)
- (inst beq x y target))
+ (inst bne x y target)
+ (inst beq x y target))
(inst nop)))
;;;; 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))))
(:effects)
(:affected)
(:generator 0
;;; 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))
(:generator 0
(sc-case y
(define-vop (pointer+)
(:translate sap+)
(:args (ptr :scs (sap-reg))
- (offset :scs (signed-reg immediate)))
+ (offset :scs (signed-reg immediate)))
(:arg-types system-area-pointer signed-num)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(define-vop (pointer-)
(:translate sap-)
(:args (ptr1 :scs (sap-reg))
- (ptr2 :scs (sap-reg)))
+ (ptr2 :scs (sap-reg)))
(:arg-types system-area-pointer system-area-pointer)
(:policy :fast-safe)
(:results (res :scs (signed-reg)))
\f
;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
(macrolet ((def-system-ref-and-set
- (ref-name set-name sc type size &optional signed)
+ (ref-name set-name sc type size &optional signed)
(let ((ref-name-c (symbolicate ref-name "-C"))
- (set-name-c (symbolicate set-name "-C")))
+ (set-name-c (symbolicate set-name "-C")))
`(progn
(define-vop (,ref-name)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (object :scs (sap-reg) :target sap)
- (offset :scs (signed-reg)))
- (:arg-types system-area-pointer signed-num)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
- (:generator 5
- (inst addu sap object offset)
- ,@(ecase size
- (:byte
- (if signed
- '((inst lb result sap 0))
- '((inst lbu result sap 0))))
- (:short
- (if signed
- '((inst lh result sap 0))
- '((inst lhu result sap 0))))
- (:long
- '((inst lw result sap 0)))
- (:single
- '((inst lwc1 result sap 0)))
- (:double
- (ecase *backend-byte-order*
- (:big-endian
- '((inst lwc1 result sap n-word-bytes)
- (inst lwc1-odd result sap 0)))
- (:little-endian
- '((inst lwc1 result sap 0)
- (inst lwc1-odd result sap n-word-bytes))))))
- (inst nop)))
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+ (:generator 5
+ (inst addu sap object offset)
+ ,@(ecase size
+ (:byte
+ (if signed
+ '((inst lb result sap 0))
+ '((inst lbu result sap 0))))
+ (:short
+ (if signed
+ '((inst lh result sap 0))
+ '((inst lhu result sap 0))))
+ (:long
+ '((inst lw result sap 0)))
+ (:single
+ '((inst lwc1 result sap 0)))
+ (:double
+ (ecase *backend-byte-order*
+ (:big-endian
+ '((inst lwc1 result sap n-word-bytes)
+ (inst lwc1-odd result sap 0)))
+ (:little-endian
+ '((inst lwc1 result sap 0)
+ (inst lwc1-odd result sap n-word-bytes))))))
+ (inst nop)))
(define-vop (,ref-name-c)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (object :scs (sap-reg)))
- (:arg-types system-area-pointer
- (:constant ,(if (eq size :double)
- ;; We need to be able to add 4.
- `(integer ,(- (ash 1 16))
- ,(- (ash 1 16) 5))
- '(signed-byte 16))))
- (:info offset)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- ,@(ecase size
- (:byte
- (if signed
- '((inst lb result object offset))
- '((inst lbu result object offset))))
- (:short
- (if signed
- '((inst lh result object offset))
- '((inst lhu result object offset))))
- (:long
- '((inst lw result object offset)))
- (:single
- '((inst lwc1 result object offset)))
- (:double
- (ecase *backend-byte-order*
- (:big-endian
- '((inst lwc1 result object (+ offset n-word-bytes))
- (inst lwc1-odd result object offset)))
- (:little-endian
- '((inst lwc1 result object offset)
- (inst lwc1-odd result object (+ offset n-word-bytes)))))))
- (inst nop)))
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :double)
+ ;; We need to be able to add 4.
+ `(integer ,(- (ash 1 16))
+ ,(- (ash 1 16) 5))
+ '(signed-byte 16))))
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ ,@(ecase size
+ (:byte
+ (if signed
+ '((inst lb result object offset))
+ '((inst lbu result object offset))))
+ (:short
+ (if signed
+ '((inst lh result object offset))
+ '((inst lhu result object offset))))
+ (:long
+ '((inst lw result object offset)))
+ (:single
+ '((inst lwc1 result object offset)))
+ (:double
+ (ecase *backend-byte-order*
+ (:big-endian
+ '((inst lwc1 result object (+ offset n-word-bytes))
+ (inst lwc1-odd result object offset)))
+ (:little-endian
+ '((inst lwc1 result object offset)
+ (inst lwc1-odd result object (+ offset n-word-bytes)))))))
+ (inst nop)))
(define-vop (,set-name)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (object :scs (sap-reg) :target sap)
- (offset :scs (signed-reg))
- (value :scs (,sc) :target result))
- (:arg-types system-area-pointer signed-num ,type)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
- (:generator 5
- (inst addu sap object offset)
- ,@(ecase size
- (:byte
- '((inst sb value sap 0)
- (move result value)))
- (:short
- '((inst sh value sap 0)
- (move result value)))
- (:long
- '((inst sw value sap 0)
- (move result value)))
- (:single
- '((inst swc1 value sap 0)
- (unless (location= result value)
- (inst fmove :single result value))))
- (:double
- (ecase *backend-byte-order*
- (:big-endian
- '((inst swc1 value sap n-word-bytes)
- (inst swc1-odd value sap 0)
- (unless (location= result value)
- (inst fmove :double result value))))
- (:little-endian
- '((inst swc1 value sap 0)
- (inst swc1-odd value sap n-word-bytes)
- (unless (location= result value)
- (inst fmove :double result value)))))))))
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (signed-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer signed-num ,type)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+ (:generator 5
+ (inst addu sap object offset)
+ ,@(ecase size
+ (:byte
+ '((inst sb value sap 0)
+ (move result value)))
+ (:short
+ '((inst sh value sap 0)
+ (move result value)))
+ (:long
+ '((inst sw value sap 0)
+ (move result value)))
+ (:single
+ '((inst swc1 value sap 0)
+ (unless (location= result value)
+ (inst fmove :single result value))))
+ (:double
+ (ecase *backend-byte-order*
+ (:big-endian
+ '((inst swc1 value sap n-word-bytes)
+ (inst swc1-odd value sap 0)
+ (unless (location= result value)
+ (inst fmove :double result value))))
+ (:little-endian
+ '((inst swc1 value sap 0)
+ (inst swc1-odd value sap n-word-bytes)
+ (unless (location= result value)
+ (inst fmove :double result value)))))))))
(define-vop (,set-name-c)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (object :scs (sap-reg))
- (value :scs (,sc) :target result))
- (:arg-types system-area-pointer
- (:constant ,(if (eq size :double)
- ;; We need to be able to add 4.
- `(integer ,(- (ash 1 16))
- ,(- (ash 1 16) 5))
- '(signed-byte 16)))
- ,type)
- (:info offset)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- ,@(ecase size
- (:byte
- '((inst sb value object offset)
- (move result value)))
- (:short
- '((inst sh value object offset)
- (move result value)))
- (:long
- '((inst sw value object offset)
- (move result value)))
- (:single
- '((inst swc1 value object offset)
- (unless (location= result value)
- (inst fmove :single result value))))
- (:double
- (ecase *backend-byte-order*
- (:big-endian
- '((inst swc1 value object (+ offset n-word-bytes))
- (inst swc1-odd value object (+ offset n-word-bytes))
- (unless (location= result value)
- (inst fmove :double result value))))
- (:little-endian
- '((inst swc1 value object offset)
- (inst swc1-odd value object (+ offset n-word-bytes))
- (unless (location= result value)
- (inst fmove :double result value)))))))))))))
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :double)
+ ;; We need to be able to add 4.
+ `(integer ,(- (ash 1 16))
+ ,(- (ash 1 16) 5))
+ '(signed-byte 16)))
+ ,type)
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(ecase size
+ (:byte
+ '((inst sb value object offset)
+ (move result value)))
+ (:short
+ '((inst sh value object offset)
+ (move result value)))
+ (:long
+ '((inst sw value object offset)
+ (move result value)))
+ (:single
+ '((inst swc1 value object offset)
+ (unless (location= result value)
+ (inst fmove :single result value))))
+ (:double
+ (ecase *backend-byte-order*
+ (:big-endian
+ '((inst swc1 value object (+ offset n-word-bytes))
+ (inst swc1-odd value object (+ offset n-word-bytes))
+ (unless (location= result value)
+ (inst fmove :double result value))))
+ (:little-endian
+ '((inst swc1 value object offset)
+ (inst swc1-odd value object (+ offset n-word-bytes))
+ (unless (location= result value)
+ (inst fmove :double result value)))))))))))))
(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
unsigned-reg positive-fixnum :byte nil)
(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
(:result-types system-area-pointer)
(:generator 2
(inst addu sap vector
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
\f
;;; Transforms for 64-bit SAP accessors.
#!+little-endian
(progn
(deftransform sap-ref-64 ((sap offset) (* *))
'(logior (sap-ref-32 sap offset)
- (ash (sap-ref-32 sap (+ offset 4)) 32)))
+ (ash (sap-ref-32 sap (+ offset 4)) 32)))
(deftransform signed-sap-ref-64 ((sap offset) (* *))
'(logior (sap-ref-32 sap offset)
- (ash (signed-sap-ref-32 sap (+ offset 4)) 32)))
+ (ash (signed-sap-ref-32 sap (+ offset 4)) 32)))
(deftransform %set-sap-ref-64 ((sap offset value) (* * *))
'(progn
(%set-sap-ref-32 sap offset (logand value #xffffffff))
(progn
(deftransform sap-ref-64 ((sap offset) (* *))
'(logior (ash (sap-ref-32 sap offset) 32)
- (sap-ref-32 sap (+ offset 4))))
+ (sap-ref-32 sap (+ offset 4))))
(deftransform signed-sap-ref-64 ((sap offset) (* *))
'(logior (ash (signed-sap-ref-32 sap offset) 32)
- (sap-ref-32 sap (+ 4 offset))))
+ (sap-ref-32 sap (+ 4 offset))))
(deftransform %set-sap-ref-64 ((sap offset value) (* * *))
'(progn
(%set-sap-ref-32 sap offset (ash value -32))
(:results (result :scs (descriptor-reg)))
(:save-p t)
(:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0))
- cfunc)
+ cfunc)
(:temporary (:sc descriptor-reg :offset 4 :from (:argument 0)) a0)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:vop-var vop)
(let ((cur-nfp (current-nfp-tn vop)))
(move a0 object)
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(inst li cfunc (make-fixup "debug_print" :foreign))
(inst jal (make-fixup "call_into_c" :foreign))
(inst addu nsp-tn nsp-tn -16)
(inst addu nsp-tn nsp-tn 16)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save))
+ (load-stack-tn cur-nfp nfp-save))
(move result cfunc))))
(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*)
- ,@(when (< i num-args)
- `(:from (:argument ,i)))
- ,@(when (< i num-results)
- `(:to (:result ,i)
- :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*)
+ ,@(when (< i num-args)
+ `(:from (:argument ,i)))
+ ,@(when (< i num-results)
+ `(:to (:result ,i)
+ :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 null zero)
- :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 null zero)
+ :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)
- (let ((lra-label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
- ,@(moves (temp-names) (arg-names))
- (inst li nargs (fixnumize ,num-args))
- (inst lw entry-point null-tn (static-fun-offset symbol))
- (when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
- (move ocfp cfp-tn)
- (inst compute-lra-from-code lra code-tn lra-label temp)
- (note-this-location vop :call-site)
- (inst j entry-point)
- (move cfp-tn csp-tn t)
- (emit-return-pc lra-label)
- ,(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 move-temp temp lra-label)))
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))
- ,@(moves (result-names) (temp-names))))))))
+ static-fun-template)
+ (:args ,@(args))
+ ,@(temps)
+ (:results ,@(results))
+ (:generator ,(+ 50 num-args num-results)
+ (let ((lra-label (gen-label))
+ (cur-nfp (current-nfp-tn vop)))
+ ,@(moves (temp-names) (arg-names))
+ (inst li nargs (fixnumize ,num-args))
+ (inst lw entry-point null-tn (static-fun-offset symbol))
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (move ocfp cfp-tn)
+ (inst compute-lra-from-code lra code-tn lra-label temp)
+ (note-this-location vop :call-site)
+ (inst j entry-point)
+ (move cfp-tn csp-tn t)
+ (emit-return-pc lra-label)
+ ,(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 move-temp temp lra-label)))
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))
+ ,@(moves (result-names) (temp-names))))))))
) ; EVAL-WHEN
(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)))))
(:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
- count)
+ count)
(:results (result :scs (any-reg descriptor-reg)))
(:policy :fast-safe)
(:vop-var vop)
(:generator 50
(move ptr object)
(move count zero-tn)
-
+
LOOP
-
+
(inst beq ptr null-tn done)
(inst nop)
-
+
(inst and temp ptr lowtag-mask)
(inst xor temp list-pointer-lowtag)
(inst bne temp zero-tn not-list)
(inst nop)
-
+
(loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
(inst b loop)
(inst addu count count (fixnumize 1))
-
+
NOT-LIST
(cerror-call vop done object-not-list-error ptr)
-
+
DONE
(move result count)))
-
+
(define-static-fun length (object) :translate length)
(define-vop (pointer-compare)
(:args (x :scs (sap-reg))
- (y :scs (sap-reg)))
+ (y :scs (sap-reg)))
(:arg-types system-area-pointer system-area-pointer)
(:temporary (:scs (non-descriptor-reg)) temp)
(:conditional)
#+nil
(macrolet ((frob (name cond)
- `(progn
- (def-primitive-translator ,name (x y) `(,',name ,x ,y))
- (defknown ,name (t t) boolean (movable foldable flushable))
- (define-vop (,name pointer-compare)
- (:translate ,name)
- (:variant ,cond)))))
+ `(progn
+ (def-primitive-translator ,name (x y) `(,',name ,x ,y))
+ (defknown ,name (t t) boolean (movable foldable flushable))
+ (define-vop (,name pointer-compare)
+ (:translate ,name)
+ (:variant ,cond)))))
(frob pointer< :lt)
(frob pointer> :gt))
OTHER-PTR
(load-type result object (- other-pointer-lowtag))
(inst nop)
-
+
DONE))
(define-vop (fun-subtype)
(:translate (setf fun-subtype))
(:policy :fast-safe)
(:args (type :scs (unsigned-reg) :target result)
- (function :scs (descriptor-reg)))
+ (function :scs (descriptor-reg)))
(:arg-types positive-fixnum *)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:translate set-header-data)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg) :target res)
- (data :scs (any-reg immediate zero)))
+ (data :scs (any-reg immediate zero)))
(:arg-types * positive-fixnum)
(:results (res :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) t1 t2)
(define-vop (make-other-immediate-type)
(:args (val :scs (any-reg descriptor-reg))
- (type :scs (any-reg descriptor-reg immediate)
- :target temp))
+ (type :scs (any-reg descriptor-reg immediate)
+ :target temp))
(:results (res :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 2
(define-vop (compute-fun)
(:args (code :scs (descriptor-reg))
- (offset :scs (signed-reg unsigned-reg)))
+ (offset :scs (signed-reg unsigned-reg)))
(:arg-types * positive-fixnum)
(:results (func :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (non-descriptor-reg)) count)
(:generator 1
(let ((offset
- (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
+ (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
(inst lw count count-vector offset)
(inst nop)
(inst addu count 1)
(assemble ()
(inst and temp value 3)
(if not-p
- (inst bne temp zero-tn target)
- (inst beq temp zero-tn target))
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
(inst nop)))
(defun %test-fixnum-and-headers (value target not-p headers &key temp)
(inst and temp value 3)
(inst beq temp zero-tn (if not-p drop-through target)))
(%test-headers value target not-p nil headers
- :drop-through drop-through :temp temp)))
+ :drop-through drop-through :temp temp)))
(defun %test-immediate (value target not-p immediate &key temp)
(assemble ()
(inst and temp value 255)
(inst xor temp immediate)
(if not-p
- (inst bne temp zero-tn target)
- (inst beq temp zero-tn target))
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
(inst nop)))
(defun %test-lowtag (value target not-p lowtag &key skip-nop temp)
(inst and temp value lowtag-mask)
(inst xor temp lowtag)
(if not-p
- (inst bne temp zero-tn target)
- (inst beq temp zero-tn target))
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
(unless skip-nop
(inst nop))))
(defun %test-headers (value target not-p function-p headers
- &key (drop-through (gen-label)) temp)
+ &key (drop-through (gen-label)) temp)
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind
- (when-true when-false)
- ;; 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 drop-through target)
- (values target drop-through))
+ (when-true when-false)
+ ;; 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 drop-through target)
+ (values target drop-through))
(assemble ()
- (%test-lowtag value when-false t lowtag :temp temp)
- (load-type temp value (- lowtag))
- (inst nop)
- (let ((delta 0))
- (do ((remaining headers (cdr remaining)))
- ((null remaining))
- (let ((header (car remaining))
- (last (null (cdr remaining))))
- (cond
- ((atom header)
- (inst subu temp (- header delta))
- (setf delta header)
- (if last
- (if not-p
- (inst bne temp zero-tn target)
- (inst beq temp zero-tn target))
- (inst beq temp zero-tn when-true)))
- (t
- (let ((start (car header))
- (end (cdr header)))
- (unless (= start bignum-widetag)
- (inst subu temp (- start delta))
- (setf delta start)
- (inst bltz temp when-false))
- (inst subu temp (- end delta))
- (setf delta end)
- (if last
- (if not-p
- (inst bgtz temp target)
- (inst blez temp target))
- (inst blez temp when-true))))))))
- (inst nop)
- (emit-label drop-through)))))
+ (%test-lowtag value when-false t lowtag :temp temp)
+ (load-type temp value (- lowtag))
+ (inst nop)
+ (let ((delta 0))
+ (do ((remaining headers (cdr remaining)))
+ ((null remaining))
+ (let ((header (car remaining))
+ (last (null (cdr remaining))))
+ (cond
+ ((atom header)
+ (inst subu temp (- header delta))
+ (setf delta header)
+ (if last
+ (if not-p
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
+ (inst beq temp zero-tn when-true)))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ (unless (= start bignum-widetag)
+ (inst subu temp (- start delta))
+ (setf delta start)
+ (inst bltz temp when-false))
+ (inst subu temp (- end delta))
+ (setf delta end)
+ (if last
+ (if not-p
+ (inst bgtz temp target)
+ (inst blez temp target))
+ (inst blez temp when-true))))))))
+ (inst nop)
+ (emit-label drop-through)))))
\f
(defun cost-to-test-types (type-codes)
(+ (* 2 (length type-codes))
(if (> (apply #'max type-codes) lowtag-limit) 7 2)))
-
+
(defmacro !define-type-vops (pred-name check-name ptype error-code
- (&rest type-codes)
- &key &allow-other-keys)
+ (&rest type-codes)
+ &key &allow-other-keys)
(let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
`(progn
,@(when pred-name
- `((define-vop (,pred-name type-predicate)
- (:translate ,pred-name)
- (:generator ,cost
- (test-type value target not-p (,@type-codes)
- :temp temp)))))
+ `((define-vop (,pred-name type-predicate)
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value target not-p (,@type-codes)
+ :temp temp)))))
,@(when check-name
- `((define-vop (,check-name check-type)
- (:generator ,cost
- (let ((err-lab
- (generate-error-code vop ,error-code value)))
- (test-type value err-lab t (,@type-codes)
- :temp temp)
- (move result value))))))
+ `((define-vop (,check-name check-type)
+ (:generator ,cost
+ (let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value err-lab t (,@type-codes)
+ :temp temp)
+ (move result value))))))
,@(when ptype
- `((primitive-type-vop ,check-name (:check) ,ptype))))))
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
\f
;;;; TYPE-VOPs for types that are more complex to test for than simple
;;;; LOWTAG and WIDETAG tests, but that are nevertheless important:
(multiple-value-bind
(yep nope)
(if not-p
- (values not-target target)
- (values target not-target))
+ (values not-target target)
+ (values target not-target))
(assemble ()
(inst and temp value 3)
(inst beq temp zero-tn yep)
(loadw temp value 0 other-pointer-lowtag)
(inst xor temp (+ (ash 1 n-widetag-bits) bignum-widetag))
(if not-p
- (inst bne temp zero-tn target)
- (inst beq temp zero-tn target))
+ (inst bne temp zero-tn target)
+ (inst beq temp zero-tn target))
(inst nop)))
(values))
(define-vop (check-signed-byte-32 check-type)
(:generator 45
(let ((loose (generate-error-code vop object-not-signed-byte-32-error
- value)))
+ value)))
(signed-byte-32-test value temp t loose okay))
OKAY
(move result value)))
;;; exactly two digits and the second digit all zeros.
(defun unsigned-byte-32-test (value temp not-p target not-target)
(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))
(assemble ()
;; Is it a fixnum?
(inst and temp value 3)
(inst beq temp zero-tn single-word)
;; If it's other than two, we can't be an (unsigned-byte 32)
(inst xor temp (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
- (+ (ash 2 n-widetag-bits) bignum-widetag)))
+ (+ (ash 2 n-widetag-bits) bignum-widetag)))
(inst bne temp zero-tn nope)
;; Get the second digit.
(loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
(inst beq temp zero-tn yep)
(inst nop)
(inst b nope)
-
+
SINGLE-WORD
;; Get the single digit.
(loadw temp value bignum-digits-offset other-pointer-lowtag)
;; positive implies (unsigned-byte 32).
FIXNUM
(if not-p
- (inst bltz temp target)
- (inst bgez temp target))
+ (inst bltz temp target)
+ (inst bgez temp target))
(inst nop)))
(values))
(define-vop (check-unsigned-byte-32 check-type)
(:generator 45
(let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
- value)))
+ value)))
(unsigned-byte-32-test value temp t loose okay))
OKAY
(move result value)))
(test-type value error t (symbol-header-widetag) :temp temp))
DROP-THRU
(move result value)))
-
+
(define-vop (consp type-predicate)
(:translate consp)
(:generator 8
(:info nvals)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg)
- :to (:result 0)
- :target start)
- start-temp)
+ :to (:result 0)
+ :target start)
+ start-temp)
(:generator 20
(move start-temp csp-tn)
(inst addu csp-tn csp-tn (* nvals n-word-bytes))
(do ((val vals (tn-ref-across val))
- (i 0 (1+ i)))
- ((null val))
+ (i 0 (1+ i)))
+ ((null val))
(let ((tn (tn-ref-tn val)))
- (sc-case tn
- (descriptor-reg
- (storew tn start-temp i))
- (control-stack
- (load-stack-tn temp tn)
- (storew temp start-temp i)))))
+ (sc-case tn
+ (descriptor-reg
+ (storew tn start-temp i))
+ (control-stack
+ (load-stack-tn temp tn)
+ (storew temp start-temp i)))))
(move start start-temp)
(inst li count (fixnumize nvals))))
(:arg-types list)
(:policy :fast-safe)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:generator 0
(move list arg)
(move start csp-tn)
-
+
LOOP
(inst beq list null-tn done)
(loadw temp list cons-car-slot list-pointer-lowtag)
(inst beq ndescr zero-tn loop)
(inst nop)
(error-call vop bogus-arg-to-values-list-error list)
-
+
DONE
(inst subu count csp-tn start)))
;;; as function arguments.
(define-vop (%more-arg-values)
(:args (context :scs (descriptor-reg any-reg) :target src)
- (skip :scs (any-reg zero immediate))
- (num :scs (any-reg) :target count))
+ (skip :scs (any-reg zero immediate))
+ (num :scs (any-reg) :target count))
(:arg-types * positive-fixnum positive-fixnum)
(:temporary (:sc any-reg :from (:argument 0)) src)
(:temporary (:sc any-reg :from (:argument 2)) dst)
(:temporary (:sc descriptor-reg :from (:argument 1)) temp)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:generator 20
(sc-case skip
(zero
(defvar *register-names* (make-array 32 :initial-element nil)))
(macrolet ((defreg (name offset)
- (let ((offset-sym (symbolicate name "-OFFSET")))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (def!constant ,offset-sym ,offset)
- (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
-
- (defregset (name &rest regs)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter ,name
- (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))))
+ (let ((offset-sym (symbolicate name "-OFFSET")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def!constant ,offset-sym ,offset)
+ (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
+
+ (defregset (name &rest regs)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter ,name
+ (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))))
;; Wired zero register.
(defreg zero 0) ; NULL
;; Reserved for assembler use.
;;;
;;; Handy macro so we don't have to keep changing all the numbers whenever
;;; we insert a new storage class.
-;;;
+;;;
(defmacro !define-storage-classes (&rest classes)
(do ((forms (list 'progn)
- (let* ((class (car classes))
- (sc-name (car class))
- (constant-name (intern (concatenate 'simple-string
- (string sc-name)
- "-SC-NUMBER"))))
- (list* `(define-storage-class ,sc-name ,index
- ,@(cdr class))
- `(defconstant ,constant-name ,index)
- `(export ',constant-name)
- forms)))
+ (let* ((class (car classes))
+ (sc-name (car class))
+ (constant-name (intern (concatenate 'simple-string
+ (string sc-name)
+ "-SC-NUMBER"))))
+ (list* `(define-storage-class ,sc-name ,index
+ ,@(cdr class))
+ `(defconstant ,constant-name ,index)
+ `(export ',constant-name)
+ forms)))
(index 0 (1+ index))
(classes classes (cdr classes)))
((null classes)
registers
:locations #.(append non-descriptor-regs descriptor-regs)
:reserve-locations #.(append reserve-non-descriptor-regs
- reserve-descriptor-regs)
+ reserve-descriptor-regs)
:constant-scs (constant zero immediate)
:save-p t
:alternate-scs (control-stack))
;;;; Random TNs for interesting registers
(macrolet ((defregtn (name sc)
- (let ((offset-sym (symbolicate name "-OFFSET"))
- (tn-sym (symbolicate name "-TN")))
- `(defparameter ,tn-sym
- (make-random-tn :kind :normal
- :sc (sc-or-lose ',sc)
- :offset ,offset-sym)))))
+ (let ((offset-sym (symbolicate name "-OFFSET"))
+ (tn-sym (symbolicate name "-TN")))
+ `(defparameter ,tn-sym
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose ',sc)
+ :offset ,offset-sym)))))
(defregtn zero any-reg)
(defregtn nargs any-reg)
(sc-number-or-lose 'null))
(symbol
(if (static-symbol-p value)
- (sc-number-or-lose 'immediate)
- nil))
+ (sc-number-or-lose 'immediate)
+ nil))
((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
- system-area-pointer character)
+ system-area-pointer character)
(sc-number-or-lose 'immediate))
(system-area-pointer
(sc-number-or-lose 'immediate))
;;;
;;; Names to use for the argument registers.
-;;;
+;;;
(defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
) ; EVAL-WHEN
;;;
(defparameter register-arg-tns
(mapcar #'(lambda (n)
- (make-random-tn :kind :normal
- :sc (sc-or-lose 'descriptor-reg)
- :offset n))
- *register-arg-offsets*))
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset n))
+ *register-arg-offsets*))
;;; This is used by the debugger.
(defconstant single-value-return-byte-offset 8)
(!def-vm-support-routine location-print-name (tn)
(declare (type tn tn))
(let ((sb (sb-name (sc-sb (tn-sc tn))))
- (offset (tn-offset tn)))
+ (offset (tn-offset tn)))
(ecase sb
(registers (or (svref *register-names* offset)
- (format nil "R~D" offset)))
+ (format nil "R~D" offset)))
(float-registers (format nil "F~D" offset))
(control-stack (format nil "CS~D" offset))
(non-descriptor-stack (format nil "NS~D" offset))
(:temporary (:scs (descriptor-reg) :type list) ptr)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
- res)
+ res)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:info num)
(:results (result :scs (descriptor-reg)))
(:node-var node)
(:generator 0
(cond ((zerop num)
- (move result null-tn))
- ((and star (= num 1))
- (move result (tn-ref-tn things)))
- (t
- (macrolet
- ((maybe-load (tn)
- (once-only ((tn tn))
- `(sc-case ,tn
- ((any-reg descriptor-reg zero null)
- ,tn)
- (control-stack
- (load-stack-tn temp ,tn)
- temp)))))
- (let* ((dx-p (node-stack-allocate-p node))
- (cons-cells (if star (1- num) num))
- (alloc (* (pad-data-block cons-size) cons-cells)))
- (pseudo-atomic (pa-flag :extra (if dx-p 0 alloc))
- (let ((allocation-area-tn (if dx-p csp-tn alloc-tn)))
- (when dx-p
- (align-csp res))
- (inst clrrwi res allocation-area-tn n-lowtag-bits)
- (inst ori res res list-pointer-lowtag)
- (when dx-p
- (inst addi csp-tn csp-tn alloc)))
- (move ptr res)
- (dotimes (i (1- cons-cells))
- (storew (maybe-load (tn-ref-tn things)) ptr
- cons-car-slot list-pointer-lowtag)
- (setf things (tn-ref-across things))
- (inst addi ptr ptr (pad-data-block cons-size))
- (storew ptr ptr
- (- cons-cdr-slot cons-size)
- list-pointer-lowtag))
- (storew (maybe-load (tn-ref-tn things)) ptr
- cons-car-slot list-pointer-lowtag)
- (storew (if star
- (maybe-load (tn-ref-tn (tn-ref-across things)))
- null-tn)
- ptr cons-cdr-slot list-pointer-lowtag))
- (move result res)))))))
+ (move result null-tn))
+ ((and star (= num 1))
+ (move result (tn-ref-tn things)))
+ (t
+ (macrolet
+ ((maybe-load (tn)
+ (once-only ((tn tn))
+ `(sc-case ,tn
+ ((any-reg descriptor-reg zero null)
+ ,tn)
+ (control-stack
+ (load-stack-tn temp ,tn)
+ temp)))))
+ (let* ((dx-p (node-stack-allocate-p node))
+ (cons-cells (if star (1- num) num))
+ (alloc (* (pad-data-block cons-size) cons-cells)))
+ (pseudo-atomic (pa-flag :extra (if dx-p 0 alloc))
+ (let ((allocation-area-tn (if dx-p csp-tn alloc-tn)))
+ (when dx-p
+ (align-csp res))
+ (inst clrrwi res allocation-area-tn n-lowtag-bits)
+ (inst ori res res list-pointer-lowtag)
+ (when dx-p
+ (inst addi csp-tn csp-tn alloc)))
+ (move ptr res)
+ (dotimes (i (1- cons-cells))
+ (storew (maybe-load (tn-ref-tn things)) ptr
+ cons-car-slot list-pointer-lowtag)
+ (setf things (tn-ref-across things))
+ (inst addi ptr ptr (pad-data-block cons-size))
+ (storew ptr ptr
+ (- cons-cdr-slot cons-size)
+ list-pointer-lowtag))
+ (storew (maybe-load (tn-ref-tn things)) ptr
+ cons-car-slot list-pointer-lowtag)
+ (storew (if star
+ (maybe-load (tn-ref-tn (tn-ref-across things)))
+ null-tn)
+ ptr cons-cdr-slot list-pointer-lowtag))
+ (move result res)))))))
(define-vop (list list-or-list*)
(:variant nil))
(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg))
- (unboxed-arg :scs (any-reg)))
+ (unboxed-arg :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed)
(:results (result :scs (descriptor-reg)))
(:generator 10
(let* ((size (+ length closure-info-offset))
- (alloc-size (pad-data-block size))
- (allocation-area-tn (if stack-allocate-p csp-tn alloc-tn)))
+ (alloc-size (pad-data-block size))
+ (allocation-area-tn (if stack-allocate-p csp-tn alloc-tn)))
(pseudo-atomic (pa-flag :extra (if stack-allocate-p 0 alloc-size))
- (when stack-allocate-p
- (align-csp result))
- (inst clrrwi. result allocation-area-tn n-lowtag-bits)
- (when stack-allocate-p
- (inst addi csp-tn csp-tn alloc-size))
- (inst ori result result fun-pointer-lowtag)
- (inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
- (storew temp result 0 fun-pointer-lowtag)))
+ (when stack-allocate-p
+ (align-csp result))
+ (inst clrrwi. result allocation-area-tn n-lowtag-bits)
+ (when stack-allocate-p
+ (inst addi csp-tn csp-tn alloc-size))
+ (inst ori result result fun-pointer-lowtag)
+ (inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
+ (storew temp result 0 fun-pointer-lowtag)))
;(inst lis temp (ash 18 10))
;(storew temp result closure-jump-insn-slot function-pointer-type)
(storew function result closure-fun-slot fun-pointer-lowtag)))
;;; The compiler likes to be able to directly make value cells.
-;;;
+;;;
(define-vop (make-value-cell)
(:args (value :to :save :scs (descriptor-reg any-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 4
(pseudo-atomic (pa-flag :extra (pad-data-block words))
(cond ((logbitp 2 lowtag)
- (inst ori result alloc-tn lowtag))
- (t
- (inst clrrwi result alloc-tn n-lowtag-bits)
- (inst ori result result lowtag)))
+ (inst ori result alloc-tn lowtag))
+ (t
+ (inst clrrwi result alloc-tn n-lowtag-bits)
+ (inst ori result result lowtag)))
(when type
- (inst lr temp (logior (ash (1- words) n-widetag-bits) type))
- (storew temp result 0 lowtag)))))
+ (inst lr temp (logior (ash (1- words) n-widetag-bits) type))
+ (storew temp result 0 lowtag)))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
(inst clrrwi bytes bytes n-lowtag-bits)
(pseudo-atomic (pa-flag)
(cond ((logbitp 2 lowtag)
- (inst ori result alloc-tn lowtag))
- (t
- (inst clrrwi result alloc-tn n-lowtag-bits)
- (inst ori result result lowtag)))
+ (inst ori result alloc-tn lowtag))
+ (t
+ (inst clrrwi result alloc-tn n-lowtag-bits)
+ (inst ori result result lowtag)))
(storew header result 0 lowtag)
(inst add alloc-tn alloc-tn bytes))))
(define-vop (fast-fixnum-binop fast-safe-arith-op)
(:args (x :target r :scs (any-reg zero))
- (y :target r :scs (any-reg zero)))
+ (y :target r :scs (any-reg zero)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(define-vop (fast-unsigned-binop fast-safe-arith-op)
(:args (x :target r :scs (unsigned-reg zero))
- (y :target r :scs (unsigned-reg zero)))
+ (y :target r :scs (unsigned-reg zero)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(define-vop (fast-signed-binop fast-safe-arith-op)
(:args (x :target r :scs (signed-reg zero))
- (y :target r :scs (signed-reg zero)))
+ (y :target r :scs (signed-reg zero)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:args (x :target r :scs (any-reg zero)))
(:info y)
(:arg-types tagged-num
- (:constant (and (signed-byte 14) (not (integer 0 0)))))
+ (:constant (and (signed-byte 14) (not (integer 0 0)))))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:note "inline fixnum arithmetic"))
(:args (x :target r :scs (any-reg zero)))
(:info y)
(:arg-types tagged-num
- (:constant (and (signed-byte 30) (not (integer 0 0)))))
+ (:constant (and (signed-byte 30) (not (integer 0 0)))))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:note "inline fixnum arithmetic"))
(:args (x :target r :scs (any-reg zero)))
(:info y)
(:arg-types tagged-num
- (:constant (and (unsigned-byte 14) (not (integer 0 0)))))
+ (:constant (and (unsigned-byte 14) (not (integer 0 0)))))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:note "inline fixnum logical op"))
(:args (x :target r :scs (any-reg zero)))
(:info y)
(:arg-types tagged-num
- (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
+ (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:note "inline fixnum logical op"))
(:args (x :target r :scs (unsigned-reg zero)))
(:info y)
(:arg-types unsigned-num
- (:constant (and (signed-byte 16) (not (integer 0 0)))))
+ (:constant (and (signed-byte 16) (not (integer 0 0)))))
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic"))
(:args (x :target r :scs (unsigned-reg zero)))
(:info y)
(:arg-types unsigned-num
- (:constant (and (unsigned-byte 32) (not (integer 0 0)))))
+ (:constant (and (unsigned-byte 32) (not (integer 0 0)))))
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic"))
(:args (x :target r :scs (signed-reg zero)))
(:info y)
(:arg-types signed-num
- (:constant (and (signed-byte 32) (not (integer 0 0)))))
+ (:constant (and (signed-byte 32) (not (integer 0 0)))))
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:note "inline (signed-byte 32) arithmetic"))
(:args (x :target r :scs (unsigned-reg zero)))
(:info y)
(:arg-types unsigned-num
- (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
+ (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) logical op"))
(:args (x :target r :scs (unsigned-reg zero)))
(:info y)
(:arg-types unsigned-num
- (:constant (and (unsigned-byte 32) (not (integer 0 0)))))
+ (:constant (and (unsigned-byte 32) (not (integer 0 0)))))
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) logical op"))
(:args (x :target r :scs (signed-reg zero)))
(:info y)
(:arg-types signed-num
- (:constant (and (unsigned-byte 32) (not (integer 0 0)))))
+ (:constant (and (unsigned-byte 32) (not (integer 0 0)))))
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:note "inline (signed-byte 32) logical op"))
(:args (x :target r :scs (signed-reg zero)))
(:info y)
(:arg-types signed-num
- (:constant (and (signed-byte 16) (not (integer 0 0)))))
+ (:constant (and (signed-byte 16) (not (integer 0 0)))))
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:note "inline (signed-byte 32) arithmetic"))
(:args (x :target r :scs (signed-reg zero)))
(:info y)
(:arg-types signed-num
- (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
+ (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:note "inline (signed-byte 32) logical op"))
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defmacro !define-var-binop (translate untagged-penalty op
+(defmacro !define-var-binop (translate untagged-penalty op
&optional arg-swap restore-fixnum-mask)
`(progn
(define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
- fast-fixnum-binop)
+ fast-fixnum-binop)
,@(when restore-fixnum-mask
- `((:temporary (:sc non-descriptor-reg) temp)))
+ `((:temporary (:sc non-descriptor-reg) temp)))
(:translate ,translate)
(:generator 2
- ,(if arg-swap
- `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
- `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
- ;; FIXME: remind me what convention we used for 64bitizing
- ;; stuff? -- CSR, 2003-08-27
- ,@(when restore-fixnum-mask
- `((inst clrrwi r temp (1- n-lowtag-bits))))))
+ ,(if arg-swap
+ `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
+ `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
+ ;; FIXME: remind me what convention we used for 64bitizing
+ ;; stuff? -- CSR, 2003-08-27
+ ,@(when restore-fixnum-mask
+ `((inst clrrwi r temp (1- n-lowtag-bits))))))
(define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
- fast-signed-binop)
+ fast-signed-binop)
(:translate ,translate)
(:generator ,(1+ untagged-penalty)
,(if arg-swap
- `(inst ,op r y x)
- `(inst ,op r x y))))
+ `(inst ,op r y x)
+ `(inst ,op r x y))))
(define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
- fast-unsigned-binop)
+ fast-unsigned-binop)
(:translate ,translate)
(:generator ,(1+ untagged-penalty)
- ,(if arg-swap
- `(inst ,op r y x)
- `(inst ,op r x y))))))
+ ,(if arg-swap
+ `(inst ,op r y x)
+ `(inst ,op r x y))))))
;;; FIXME: the code has really only been checked for adds; we could do
;;; subtracts, too, but my brain is not up to the task of figuring out
(defmacro !define-const-binop (translate untagged-penalty op &optional (shifted-op nil))
`(progn
(define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
- ,(if shifted-op
+ ,(if shifted-op
'fast-fixnum-binop30-c
'fast-fixnum-binop-c))
(:translate ,translate)
(inst ,op r temp low-half)))))
`(inst ,op r x (fixnumize y)))))
(define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
- ,(if shifted-op
+ ,(if shifted-op
'fast-signed-binop32-c
'fast-signed-binop-c))
(:translate ,translate)
(inst ,op r temp low-half)))))
`(inst ,op r x y))))
(define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
- ,(if shifted-op
+ ,(if shifted-op
'fast-unsigned-binop32-c
'fast-unsigned-binop-c))
(:translate ,translate)
(defmacro !define-const-logop (translate untagged-penalty op &optional (shifted-op nil))
`(progn
(define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
- ,(if shifted-op
+ ,(if shifted-op
'fast-fixnum-logop30-c
'fast-fixnum-logop-c))
(:translate ,translate)
(inst ,op r temp low-half))))
`(inst ,op r x (fixnumize y)))))
(define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
- ,(if shifted-op
+ ,(if shifted-op
'fast-signed-logop32-c
'fast-signed-logop-c))
(:translate ,translate)
,@(when shifted-op
`((:temporary (:sc non-descriptor-reg :target r) temp)))
(:generator ,untagged-penalty
- ,(if shifted-op
+ ,(if shifted-op
`(let ((high-half (ldb (byte 16 16) y))
(low-half (ldb (byte 16 0) y)))
(cond
(inst ,op r temp low-half))))
`(inst ,op r x y))))
(define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
- ,(if shifted-op
+ ,(if shifted-op
'fast-unsigned-logop32-c
'fast-unsigned-logop-c))
(:translate ,translate)
(inst addo. r x y)
(inst bns no-overflow)
(inst unimp (logior (ash (reg-tn-encoding r) 5)
- fixnum-additive-overflow-trap))
+ fixnum-additive-overflow-trap))
(emit-label no-overflow))))
(define-vop (-/fixnum fast--/fixnum=>fixnum)
(inst subo. r x y)
(inst bns no-overflow)
(inst unimp (logior (ash (reg-tn-encoding r) 5)
- fixnum-additive-overflow-trap))
+ fixnum-additive-overflow-trap))
(emit-label no-overflow))))
(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
(define-vop (fast-*-c/fixnum=>fixnum fast-fixnum-binop-c)
(:translate *)
- (:arg-types tagged-num
- (:constant (and (signed-byte 16) (not (integer 0 0)))))
+ (:arg-types tagged-num
+ (:constant (and (signed-byte 16) (not (integer 0 0)))))
(:generator 1
(inst mulli r x y)))
(define-vop (fast-*-bigc/fixnum=>fixnum fast-fixnum-binop-c)
(:translate *)
(:arg-types tagged-num
- (:constant (and fixnum (not (signed-byte 16)))))
+ (:constant (and fixnum (not (signed-byte 16)))))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 1
(inst lr temp y)
;;; Shifting
(macrolet ((def (name sc-type type result-type cost)
- `(define-vop (,name)
- (:note "inline ASH")
- (:translate ash)
- (:args (number :scs (,sc-type))
- (amount :scs (signed-reg unsigned-reg immediate)))
- (:arg-types ,type positive-fixnum)
- (:results (result :scs (,result-type)))
- (:result-types ,type)
- (:policy :fast-safe)
- (:generator ,cost
- (sc-case amount
- ((signed-reg unsigned-reg)
- (inst slw result number amount))
- (immediate
- (let ((amount (tn-value amount)))
- (aver (> amount 0))
- (inst slwi result number amount))))))))
+ `(define-vop (,name)
+ (:note "inline ASH")
+ (:translate ash)
+ (:args (number :scs (,sc-type))
+ (amount :scs (signed-reg unsigned-reg immediate)))
+ (:arg-types ,type positive-fixnum)
+ (:results (result :scs (,result-type)))
+ (:result-types ,type)
+ (:policy :fast-safe)
+ (:generator ,cost
+ (sc-case amount
+ ((signed-reg unsigned-reg)
+ (inst slw result number amount))
+ (immediate
+ (let ((amount (tn-value amount)))
+ (aver (> amount 0))
+ (inst slwi result number amount))))))))
;; FIXME: There's the opportunity for a sneaky optimization here, I
;; think: a FAST-ASH-LEFT-C/FIXNUM=>SIGNED vop. -- CSR, 2003-09-03
(def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
(define-vop (fast-ash/unsigned=>unsigned)
(:note "inline ASH")
(:args (number :scs (unsigned-reg) :to :save)
- (amount :scs (signed-reg)))
+ (amount :scs (signed-reg)))
(:arg-types (:or unsigned-num) signed-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:temporary (:sc non-descriptor-reg) ndesc)
(:generator 5
(let ((positive (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst cmpwi amount 0)
(inst neg ndesc amount)
(inst bge positive)
(inst ble done)
(move result zero-tn)
(inst b done)
-
+
(emit-label positive)
;; The result-type assures us that this shift will not overflow.
(inst slw result number amount)
-
+
(emit-label done))))
(define-vop (fast-ash-c/unsigned=>unsigned)
(define-vop (fast-ash/signed=>signed)
(:note "inline ASH")
(:args (number :scs (signed-reg) :to :save)
- (amount :scs (signed-reg immediate)))
+ (amount :scs (signed-reg immediate)))
(:arg-types (:or signed-num) signed-num)
(:results (result :scs (signed-reg)))
(:result-types (:or signed-num))
(sc-case amount
(signed-reg
(let ((positive (gen-label))
- (done (gen-label)))
- (inst cmpwi amount 0)
- (inst neg ndesc amount)
- (inst bge positive)
- (inst cmpwi ndesc 31)
- (inst sraw result number ndesc)
- (inst ble done)
- (inst srawi result number 31)
- (inst b done)
-
- (emit-label positive)
- ;; The result-type assures us that this shift will not overflow.
- (inst slw result number amount)
-
- (emit-label done)))
+ (done (gen-label)))
+ (inst cmpwi amount 0)
+ (inst neg ndesc amount)
+ (inst bge positive)
+ (inst cmpwi ndesc 31)
+ (inst sraw result number ndesc)
+ (inst ble done)
+ (inst srawi result number 31)
+ (inst b done)
+
+ (emit-label positive)
+ ;; The result-type assures us that this shift will not overflow.
+ (inst slw result number amount)
+
+ (emit-label done)))
(immediate
(let ((amount (tn-value amount)))
- (if (minusp amount)
- (let ((amount (min 31 (- amount))))
- (inst srawi result number amount))
- (inst slwi result number amount)))))))
+ (if (minusp amount)
+ (let ((amount (min 31 (- amount))))
+ (inst srawi result number amount))
+ (inst slwi result number amount)))))))
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp)
(:generator 30
(let ((loop (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst add. shift zero-tn arg)
(move res zero-tn)
(inst beq done)
(inst not res x)))
(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
- fast-ash-c/unsigned=>unsigned)
+ fast-ash-c/unsigned=>unsigned)
(:translate ash-left-mod32))
(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))
-(macrolet
+(macrolet
((define-modular-backend (fun &optional constantp)
(let ((mfun-name (symbolicate fun '-mod32))
- (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
- (modcvop (symbolicate 'fast- fun 'mod32-c/unsigned=>unsigned))
- (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
- (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
- `(progn
- (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
- (define-vop (,modvop ,vop)
- (:translate ,mfun-name))
- ,@(when constantp
- `((define-vop (,modcvop ,cvop)
- (:translate ,mfun-name))))))))
+ (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
+ (modcvop (symbolicate 'fast- fun 'mod32-c/unsigned=>unsigned))
+ (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
+ (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
+ `(progn
+ (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
+ (define-vop (,modvop ,vop)
+ (:translate ,mfun-name))
+ ,@(when constantp
+ `((define-vop (,modcvop ,cvop)
+ (:translate ,mfun-name))))))))
(define-modular-backend + t)
(define-modular-backend - t)
(define-modular-backend * t)
(define-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg zero))
- (y :scs (any-reg zero)))
+ (y :scs (any-reg zero)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison"))
(define-vop (fast-conditional/signed fast-conditional)
(:args (x :scs (signed-reg zero))
- (y :scs (signed-reg zero)))
+ (y :scs (signed-reg zero)))
(:arg-types signed-num signed-num)
(:note "inline (signed-byte 32) comparison"))
(define-vop (fast-conditional/unsigned fast-conditional)
(:args (x :scs (unsigned-reg zero))
- (y :scs (unsigned-reg zero)))
+ (y :scs (unsigned-reg zero)))
(:arg-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 32) comparison"))
(define-vop (fast-eql/fixnum fast-conditional)
(:args (x :scs (any-reg descriptor-reg zero))
- (y :scs (any-reg zero)))
+ (y :scs (any-reg zero)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison")
(:translate eql)
(define-vop (merge-bits)
(:translate merge-bits)
(:args (shift :scs (signed-reg unsigned-reg))
- (prev :scs (unsigned-reg))
- (next :scs (unsigned-reg)))
+ (prev :scs (unsigned-reg))
+ (next :scs (unsigned-reg)))
(:arg-types tagged-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
(define-vop (shift-towards-someplace)
(:policy :fast-safe)
(:args (num :scs (unsigned-reg))
- (amount :scs (signed-reg)))
+ (amount :scs (signed-reg)))
(:arg-types unsigned-num tagged-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num))
(:variant bignum-digits-offset other-pointer-lowtag)
(:translate sb!bignum:%bignum-set)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg immediate zero))
- (value :scs (unsigned-reg)))
+ (index :scs (any-reg immediate zero))
+ (value :scs (unsigned-reg)))
(:arg-types t positive-fixnum unsigned-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num))
(:translate sb!bignum:%add-with-carry)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
- (b :scs (unsigned-reg))
- (c :scs (any-reg)))
+ (b :scs (unsigned-reg))
+ (c :scs (any-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:temporary (:scs (unsigned-reg)) temp)
(:results (result :scs (unsigned-reg))
- (carry :scs (unsigned-reg)))
+ (carry :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 3
(inst addic temp c -1)
(:translate sb!bignum:%subtract-with-borrow)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
- (b :scs (unsigned-reg))
- (c :scs (any-reg)))
+ (b :scs (unsigned-reg))
+ (c :scs (any-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:temporary (:scs (unsigned-reg)) temp)
(:results (result :scs (unsigned-reg))
- (borrow :scs (unsigned-reg)))
+ (borrow :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 4
(inst addic temp c -1)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg))
- (y :scs (unsigned-reg))
- (carry-in :scs (unsigned-reg) :to (:eval 1)))
+ (y :scs (unsigned-reg))
+ (carry-in :scs (unsigned-reg) :to (:eval 1)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
(:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
- :target lo) lo-temp)
+ :target lo) lo-temp)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 40
(inst mulhwu hi-temp x y)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg))
- (y :scs (unsigned-reg))
- (prev :scs (unsigned-reg) :to (:eval 1))
- (carry-in :scs (unsigned-reg) :to (:eval 1)))
+ (y :scs (unsigned-reg))
+ (prev :scs (unsigned-reg) :to (:eval 1))
+ (carry-in :scs (unsigned-reg) :to (:eval 1)))
(:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
(:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
- :target lo) lo-temp)
+ :target lo) lo-temp)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 40
(inst mulhwu hi-temp x y)
(:translate sb!bignum:%multiply)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :to (:eval 1))
- (y :scs (unsigned-reg) :to (:eval 1)))
+ (y :scs (unsigned-reg) :to (:eval 1)))
(:arg-types unsigned-num unsigned-num)
(:results (hi :scs (unsigned-reg) :from (:eval 1))
- (lo :scs (unsigned-reg) :from (:eval 0)))
+ (lo :scs (unsigned-reg) :from (:eval 0)))
(:result-types unsigned-num unsigned-num)
(:generator 40
(inst mullw lo x y)
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (num-high :scs (unsigned-reg) :target rem)
- (num-low :scs (unsigned-reg) :target rem-low)
- (denom :scs (unsigned-reg) :to (:eval 1)))
+ (num-low :scs (unsigned-reg) :target rem-low)
+ (denom :scs (unsigned-reg) :to (:eval 1)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low)
(:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
(:results (quo :scs (unsigned-reg) :from (:eval 0))
- (rem :scs (unsigned-reg) :from (:argument 0)))
+ (rem :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num unsigned-num)
(:generator 325 ; number of inst assuming targeting works.
(move rem num-high)
(move rem-low num-low)
(flet ((maybe-subtract (&optional (guess temp))
- (inst subi temp guess 1)
- (inst and temp temp denom)
- (inst sub rem rem temp))
- (sltu (res x y)
- (inst subfc res y x)
- (inst subfe res res res)
- (inst neg res res)))
+ (inst subi temp guess 1)
+ (inst and temp temp denom)
+ (inst sub rem rem temp))
+ (sltu (res x y)
+ (inst subfc res y x)
+ (inst subfe res res res)
+ (inst neg res res)))
(sltu quo rem denom)
(maybe-subtract quo)
(dotimes (i 32)
- (inst slwi rem rem 1)
- (inst srwi temp rem-low 31)
- (inst or rem rem temp)
- (inst slwi rem-low rem-low 1)
- (sltu temp rem denom)
- (inst slwi quo quo 1)
- (inst or quo quo temp)
- (maybe-subtract)))
+ (inst slwi rem rem 1)
+ (inst srwi temp rem-low 31)
+ (inst or rem rem temp)
+ (inst slwi rem-low rem-low 1)
+ (sltu temp rem denom)
+ (inst slwi quo quo 1)
+ (inst or quo quo temp)
+ (maybe-subtract)))
(inst not quo quo)))
#|
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (div-high :scs (unsigned-reg) :target rem)
- (div-low :scs (unsigned-reg) :target quo)
- (divisor :scs (unsigned-reg)))
+ (div-low :scs (unsigned-reg) :target quo)
+ (divisor :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:results (quo :scs (unsigned-reg) :from (:argument 1))
- (rem :scs (unsigned-reg) :from (:argument 0)))
+ (rem :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num unsigned-num)
(:generator 300
(inst mtmq div-low)
(:translate sb!bignum:%ashr)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg))
- (count :scs (unsigned-reg)))
+ (count :scs (unsigned-reg)))
(:arg-types unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(in-package "SB!C")
(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 shifts and adds"
(let ((y (lvar-value y)))
(multiple-value-bind (result adds shifts)
- (ub32-strength-reduce-constant-multiply 'x y)
+ (ub32-strength-reduce-constant-multiply 'x y)
(cond
((typep y '(signed-byte 16))
- ;; a mulli instruction has a latency of 5.
- (when (> (+ adds shifts) 4)
- (give-up-ir1-transform)))
+ ;; a mulli instruction has a latency of 5.
+ (when (> (+ adds shifts) 4)
+ (give-up-ir1-transform)))
(t
- ;; a mullw instruction also has a latency of 5, plus two
- ;; instructions (in general) to load the immediate into a
- ;; register.
- (when (> (+ adds shifts) 6)
- (give-up-ir1-transform))))
+ ;; a mullw instruction also has a latency of 5, plus two
+ ;; instructions (in general) to load the immediate into a
+ ;; register.
+ (when (> (+ adds shifts) 6)
+ (give-up-ir1-transform))))
(or result 0))))
(:translate make-array-header)
(:policy :fast-safe)
(:args (type :scs (any-reg))
- (rank :scs (any-reg)))
+ (rank :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(: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))
(:results (result :scs (any-reg descriptor-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(let ((error (generate-error-code vop invalid-array-index-error
- array bound index)))
+ array bound index)))
(inst cmplw index bound)
(inst bge error)
(move result index))))
(macrolet ((def-data-vector-frobs (type variant element-type &rest scs)
`(progn
(define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
- ,(symbolicate (string variant) "-REF"))
+ ,(symbolicate (string variant) "-REF"))
(:note "inline array access")
(:variant vector-data-offset other-pointer-lowtag)
(:translate data-vector-ref)
(:results (value :scs ,scs))
(:result-types ,element-type))
(define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
- ,(symbolicate (string variant) "-SET"))
+ ,(symbolicate (string variant) "-SET"))
(:note "inline array store")
(:variant vector-data-offset other-pointer-lowtag)
(:translate data-vector-set)
(:arg-types ,type positive-fixnum ,element-type)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs ,scs))
+ (index :scs (any-reg zero immediate))
+ (value :scs ,scs))
(:results (result :scs ,scs))
(:result-types ,element-type)))))
(def-data-vector-frobs simple-base-string byte-index
unsigned-num unsigned-reg)
(def-data-vector-frobs simple-array-unsigned-byte-32 word-index
unsigned-num unsigned-reg)
-
+
(def-data-vector-frobs simple-array-unsigned-byte-29 word-index
positive-fixnum any-reg)
(def-data-vector-frobs simple-array-signed-byte-30 word-index
;;; Integer vectors whos elements are smaller than a byte. I.e. 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))))
+ (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 (value :scs (any-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
- (:generator 20
- (inst srwi temp index ,bit-shift)
- (inst slwi temp temp 2)
- (inst addi temp temp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- (inst lwzx result object temp)
- (inst andi. temp index ,(1- elements-per-word))
- (inst xori temp temp ,(1- elements-per-word))
- ,@(unless (= bits 1)
- `((inst slwi temp temp ,(1- (integer-length bits)))))
- (inst srw result result temp)
- (inst andi. result result ,(1- (ash 1 bits)))
- (inst slwi value result 2)))
+ (: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 (value :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
+ (:generator 20
+ (inst srwi temp index ,bit-shift)
+ (inst slwi temp temp 2)
+ (inst addi temp temp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst lwzx result object temp)
+ (inst andi. temp index ,(1- elements-per-word))
+ (inst xori temp temp ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst slwi temp temp ,(1- (integer-length bits)))))
+ (inst srw result result temp)
+ (inst andi. result result ,(1- (ash 1 bits)))
+ (inst slwi value result 2)))
(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)
- (:temporary (:scs (non-descriptor-reg)) temp)
- (:generator 15
- (multiple-value-bind (word extra)
- (floor index ,elements-per-word)
- (setf extra (logxor extra (1- ,elements-per-word)))
- (let ((offset (- (* (+ word vector-data-offset)
- n-word-bytes)
- other-pointer-lowtag)))
- (cond ((typep offset '(signed-byte 16))
- (inst lwz result object offset))
- (t
- (inst lr temp offset)
- (inst lwzx result object temp))))
- (unless (zerop extra)
- (inst srwi result result (* ,bits extra)))
- (unless (= extra ,(1- elements-per-word))
- (inst andi. result 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)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 15
+ (multiple-value-bind (word extra)
+ (floor index ,elements-per-word)
+ (setf extra (logxor extra (1- ,elements-per-word)))
+ (let ((offset (- (* (+ word vector-data-offset)
+ n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 16))
+ (inst lwz result object offset))
+ (t
+ (inst lr temp offset)
+ (inst lwzx result object temp))))
+ (unless (zerop extra)
+ (inst srwi result result (* ,bits extra)))
+ (unless (= extra ,(1- elements-per-word))
+ (inst andi. result 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))
- (index :scs (unsigned-reg) :target shift)
- (value :scs (unsigned-reg zero immediate) :target result))
- (:arg-types ,type positive-fixnum positive-fixnum)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg)) temp old offset)
- (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
- (:generator 25
- (inst srwi offset index ,bit-shift)
- (inst slwi offset offset 2)
- (inst addi offset offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- (inst lwzx old object offset)
- (inst andi. shift index ,(1- elements-per-word))
- (inst xori shift shift ,(1- elements-per-word))
- ,@(unless (= bits 1)
- `((inst slwi shift shift ,(1- (integer-length bits)))))
- (unless (and (sc-is value immediate)
- (= (tn-value value) ,(1- (ash 1 bits))))
- (inst lr temp ,(1- (ash 1 bits)))
- (inst slw temp temp shift)
- (inst not temp temp)
- (inst and old old temp))
- (unless (sc-is value zero)
- (sc-case value
- (immediate
- (inst lr temp (logand (tn-value value) ,(1- (ash 1 bits)))))
- (unsigned-reg
- (inst andi. temp value ,(1- (ash 1 bits)))))
- (inst slw temp temp shift)
- (inst or old old temp))
- (inst stwx old object offset)
- (sc-case value
- (immediate
- (inst lr result (tn-value value)))
- (t
- (move result value)))))
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg) :target shift)
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type positive-fixnum positive-fixnum)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) temp old offset)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
+ (:generator 25
+ (inst srwi offset index ,bit-shift)
+ (inst slwi offset offset 2)
+ (inst addi offset offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst lwzx old object offset)
+ (inst andi. shift index ,(1- elements-per-word))
+ (inst xori shift shift ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst slwi shift shift ,(1- (integer-length bits)))))
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (inst lr temp ,(1- (ash 1 bits)))
+ (inst slw temp temp shift)
+ (inst not temp temp)
+ (inst and old old temp))
+ (unless (sc-is value zero)
+ (sc-case value
+ (immediate
+ (inst lr temp (logand (tn-value value) ,(1- (ash 1 bits)))))
+ (unsigned-reg
+ (inst andi. temp value ,(1- (ash 1 bits)))))
+ (inst slw temp temp shift)
+ (inst or old old temp))
+ (inst stwx old object offset)
+ (sc-case value
+ (immediate
+ (inst lr result (tn-value value)))
+ (t
+ (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 zero immediate) :target result))
- (:arg-types ,type
- (:constant index)
- positive-fixnum)
- (:info index)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
- (:generator 20
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
- other-pointer-lowtag)))
- (cond ((typep offset '(signed-byte 16))
- (inst lwz old object offset))
- (t
- (inst lr offset-reg offset)
- (inst lwzx old object offset-reg)))
- (unless (and (sc-is value immediate)
- (= (tn-value value) ,(1- (ash 1 bits))))
- (cond ((zerop extra)
- (inst slwi old old ,bits)
- (inst srwi old old ,bits))
- (t
- (inst lr temp
- (lognot (ash ,(1- (ash 1 bits))
- (* (logxor extra
- ,(1- elements-per-word))
- ,bits))))
- (inst and old old temp))))
- (sc-case value
- (zero)
- (immediate
- (let ((value (ash (logand (tn-value value)
- ,(1- (ash 1 bits)))
- (* (logxor extra
- ,(1- elements-per-word))
- ,bits))))
- (cond ((typep value '(unsigned-byte 16))
- (inst ori old old value))
- (t
- (inst lr temp value)
- (inst or old old temp)))))
- (unsigned-reg
- (inst slwi temp value
- (* (logxor extra ,(1- elements-per-word)) ,bits))
- (inst or old old temp)))
- (if (typep offset '(signed-byte 16))
- (inst stw old object offset)
- (inst stwx old object offset-reg)))
- (sc-case value
- (immediate
- (inst lr result (tn-value value)))
- (t
- (move result value))))))))))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type
+ (:constant index)
+ positive-fixnum)
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 16))
+ (inst lwz old object offset))
+ (t
+ (inst lr offset-reg offset)
+ (inst lwzx old object offset-reg)))
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (cond ((zerop extra)
+ (inst slwi old old ,bits)
+ (inst srwi old old ,bits))
+ (t
+ (inst lr temp
+ (lognot (ash ,(1- (ash 1 bits))
+ (* (logxor extra
+ ,(1- elements-per-word))
+ ,bits))))
+ (inst and old old temp))))
+ (sc-case value
+ (zero)
+ (immediate
+ (let ((value (ash (logand (tn-value value)
+ ,(1- (ash 1 bits)))
+ (* (logxor extra
+ ,(1- elements-per-word))
+ ,bits))))
+ (cond ((typep value '(unsigned-byte 16))
+ (inst ori old old value))
+ (t
+ (inst lr temp value)
+ (inst or old old temp)))))
+ (unsigned-reg
+ (inst slwi temp value
+ (* (logxor extra ,(1- elements-per-word)) ,bits))
+ (inst or old old temp)))
+ (if (typep offset '(signed-byte 16))
+ (inst stw old object offset)
+ (inst stwx old object offset-reg)))
+ (sc-case value
+ (immediate
+ (inst lr result (tn-value value)))
+ (t
+ (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))
;;; And the float variants.
-;;;
+;;;
(define-vop (data-vector-ref/simple-array-single-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-single-float positive-fixnum)
(:results (value :scs (single-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(:result-types single-float)
(:generator 5
(inst addi offset index (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst lfsx value object offset)))
(: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)
(:temporary (:scs (non-descriptor-reg)) offset)
(:generator 5
(inst addi offset index
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
(inst stfsx value object offset)
(unless (location= result value)
(inst frsp 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 slwi offset index 1)
(inst addi offset offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst lfdx value object offset)))
(define-vop (data-vector-set/simple-array-double-float)
(: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 slwi offset index 1)
(inst addi offset offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst stfdx value object offset)
(unless (location= result value)
(inst fmr 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)))
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(let ((real-tn (complex-single-reg-real-tn value)))
(inst slwi offset index 1)
(inst addi offset offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst lfsx real-tn object offset))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(inst addi offset offset n-word-bytes)
(: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)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(: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 slwi offset index 1)
(inst addi offset offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst stfsx value-real object offset)
(unless (location= result-real value-real)
- (inst frsp result-real value-real)))
+ (inst frsp 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 addi offset offset n-word-bytes)
(inst stfsx value-imag object offset)
(unless (location= result-imag value-imag)
- (inst frsp result-imag value-imag)))))
+ (inst frsp result-imag value-imag)))))
(define-vop (data-vector-ref/simple-array-complex-double-float)
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (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)
(let ((real-tn (complex-double-reg-real-tn value)))
(inst slwi offset index 2)
(inst addi offset offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst lfdx real-tn object offset))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(inst addi offset offset (* 2 n-word-bytes))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (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)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(: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 slwi offset index 2)
(inst addi offset offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst stfdx value-real object offset)
(unless (location= result-real value-real)
- (inst fmr result-real value-real)))
+ (inst fmr 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 addi offset offset (* 2 n-word-bytes))
(inst stfdx value-imag object offset)
(unless (location= result-imag value-imag)
- (inst fmr result-imag value-imag)))))
+ (inst fmr result-imag value-imag)))))
\f
;;; These VOPs are used for implementing float slots in structures (whose raw
(:arg-types sb!c::raw-vector positive-fixnum double-float))
(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-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-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-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))
;;; These vops are useful for accessing the bits of a vector irrespective of
;;; what type of vector it is.
-;;;
+;;;
(define-vop (raw-bits word-index-ref)
(:note "raw-bits VOP")
(:note "setf raw-bits VOP")
(:translate %set-raw-bits)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs (unsigned-reg)))
+ (index :scs (any-reg zero immediate))
+ (value :scs (unsigned-reg)))
(:arg-types * positive-fixnum unsigned-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "setf vector-raw-bits VOP")
(:translate %set-vector-raw-bits)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs (unsigned-reg)))
+ (index :scs (any-reg zero immediate))
+ (value :scs (unsigned-reg)))
(:arg-types * positive-fixnum unsigned-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:translate data-vector-set)
(:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs (signed-reg)))
+ (index :scs (any-reg zero immediate))
+ (value :scs (signed-reg)))
(:results (result :scs (signed-reg)))
(:result-types tagged-num))
(define-vop (data-vector-ref/simple-array-signed-byte-16
- signed-halfword-index-ref)
+ signed-halfword-index-ref)
(:note "inline array access")
(:variant vector-data-offset other-pointer-lowtag)
(:translate data-vector-ref)
(:translate data-vector-set)
(:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs (signed-reg)))
+ (index :scs (any-reg zero immediate))
+ (value :scs (signed-reg)))
(:results (result :scs (signed-reg)))
(:result-types tagged-num))
(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
(gpr-args 0)
(defun int-arg (state prim-type reg-sc stack-sc)
(let ((reg-args (arg-state-gpr-args state)))
(cond ((< reg-args 8)
- (setf (arg-state-gpr-args state) (1+ reg-args))
- (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
- (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-gpr-args state) (1+ reg-args))
+ (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
+ (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)
(declare (ignore type))
(let* ((fprs (arg-state-fpr-args state)))
(cond ((< fprs 8)
- (incf (arg-state-fpr-args state))
- ;; Assign outgoing FPRs starting at FP1
- (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
- (t
- (let* ((stack-offset (arg-state-stack-frame-size state)))
- (if (oddp stack-offset)
- (incf stack-offset))
- (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
- (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
+ (incf (arg-state-fpr-args state))
+ ;; Assign outgoing FPRs starting at FP1
+ (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
+ (t
+ (let* ((stack-offset (arg-state-stack-frame-size state)))
+ (if (oddp stack-offset)
+ (incf stack-offset))
+ (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
+ (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
#!+darwin
(define-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let* ((fprs (arg-state-fpr-args state))
- (gprs (arg-state-gpr-args state)))
+ (gprs (arg-state-gpr-args state)))
(cond ((< gprs 8) ; and by implication also (< fprs 13)
- ;; Corresponding GPR is kept empty for functions with fixed args
- (incf (arg-state-gpr-args state))
- (incf (arg-state-fpr-args state))
- ;; Assign outgoing FPRs starting at FP1
- (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
- ((< fprs 13)
- ;; According to PowerOpen ABI, we need to pass those both in the
- ;; FPRs _and_ the stack. However empiric testing on OS X/gcc
- ;; shows they are only passed in FPRs, AFAICT.
- ;;
- ;; "I" in "AFAICT" probably refers to PRM. -- CSR, still
- ;; reverse-engineering comments in 2003 :-)
- (incf (arg-state-fpr-args state))
- (incf (arg-state-stack-frame-size state))
- (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
- (t
- ;; Pass on stack only
- (let ((stack-offset (arg-state-stack-frame-size state)))
- (incf (arg-state-stack-frame-size state))
- (my-make-wired-tn 'single-float 'single-stack stack-offset))))))
+ ;; Corresponding GPR is kept empty for functions with fixed args
+ (incf (arg-state-gpr-args state))
+ (incf (arg-state-fpr-args state))
+ ;; Assign outgoing FPRs starting at FP1
+ (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
+ ((< fprs 13)
+ ;; According to PowerOpen ABI, we need to pass those both in the
+ ;; FPRs _and_ the stack. However empiric testing on OS X/gcc
+ ;; shows they are only passed in FPRs, AFAICT.
+ ;;
+ ;; "I" in "AFAICT" probably refers to PRM. -- CSR, still
+ ;; reverse-engineering comments in 2003 :-)
+ (incf (arg-state-fpr-args state))
+ (incf (arg-state-stack-frame-size state))
+ (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
+ (t
+ ;; Pass on stack only
+ (let ((stack-offset (arg-state-stack-frame-size state)))
+ (incf (arg-state-stack-frame-size state))
+ (my-make-wired-tn 'single-float 'single-stack stack-offset))))))
#!-darwin
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let* ((fprs (arg-state-fpr-args state)))
(cond ((< fprs 8)
- (incf (arg-state-fpr-args state))
- ;; Assign outgoing FPRs starting at FP1
- (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
- (t
- (let* ((stack-offset (arg-state-stack-frame-size state)))
- (if (oddp stack-offset)
- (incf stack-offset))
- (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
- (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
-
+ (incf (arg-state-fpr-args state))
+ ;; Assign outgoing FPRs starting at FP1
+ (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
+ (t
+ (let* ((stack-offset (arg-state-stack-frame-size state)))
+ (if (oddp stack-offset)
+ (incf stack-offset))
+ (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
+ (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
+
#!+darwin
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((fprs (arg-state-fpr-args state))
- (gprs (arg-state-gpr-args state)))
+ (gprs (arg-state-gpr-args state)))
(cond ((< gprs 8) ; and by implication also (< fprs 13)
- ;; Corresponding GPRs are also kept empty
- (incf (arg-state-gpr-args state) 2)
- (when (> (arg-state-gpr-args state) 8)
- ;; Spill one word to stack
- (decf (arg-state-gpr-args state))
- (incf (arg-state-stack-frame-size state)))
- (incf (arg-state-fpr-args state))
- ;; Assign outgoing FPRs starting at FP1
- (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
- ((< fprs 13)
- ;; According to PowerOpen ABI, we need to pass those both in the
- ;; FPRs _and_ the stack. However empiric testing on OS X/gcc
- ;; shows they are only passed in FPRs, AFAICT.
- (incf (arg-state-stack-frame-size state) 2)
- (incf (arg-state-fpr-args state))
- (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
- (t
- ;; Pass on stack only
- (let ((stack-offset (arg-state-stack-frame-size state)))
- (incf (arg-state-stack-frame-size state) 2)
- (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
+ ;; Corresponding GPRs are also kept empty
+ (incf (arg-state-gpr-args state) 2)
+ (when (> (arg-state-gpr-args state) 8)
+ ;; Spill one word to stack
+ (decf (arg-state-gpr-args state))
+ (incf (arg-state-stack-frame-size state)))
+ (incf (arg-state-fpr-args state))
+ ;; Assign outgoing FPRs starting at FP1
+ (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
+ ((< fprs 13)
+ ;; According to PowerOpen ABI, we need to pass those both in the
+ ;; FPRs _and_ the stack. However empiric testing on OS X/gcc
+ ;; shows they are only passed in FPRs, AFAICT.
+ (incf (arg-state-stack-frame-size state) 2)
+ (incf (arg-state-fpr-args state))
+ (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
+ (t
+ ;; Pass on stack only
+ (let ((stack-offset (arg-state-stack-frame-size state)))
+ (incf (arg-state-stack-frame-size state) 2)
+ (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
;;; Result state handling
(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))))
#!-darwin
(define-alien-type-method (single-float :result-tn) (type)
#!-darwin
(define-alien-type-method (values :result-tn) (type)
(mapcar #'(lambda (type)
- (invoke-alien-type-method :result-tn type))
- (alien-values-type-values type)))
+ (invoke-alien-type-method :result-tn type))
+ (alien-values-type-values type)))
#!+darwin
(define-alien-type-method (values :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)))
#!-darwin
(define-alien-type-method (integer :result-tn) (type)
(if (alien-integer-type-signed 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-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)))))
-
+
(!def-vm-support-routine make-call-out-tns (type)
(declare (type alien-fun-type 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 nsp-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)
- #!+darwin (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)
+ #!+darwin (make-result-state))))))
#!+darwin
(deftransform %alien-funcall ((function type &rest args))
(aver (sb!c::constant-lvar-p type))
(let* ((type (sb!c::lvar-value type))
- (arg-types (alien-fun-type-arg-types type))
- (result-type (alien-fun-type-result-type type)))
+ (arg-types (alien-fun-type-arg-types type))
+ (result-type (alien-fun-type-result-type type)))
(aver (= (length arg-types) (length args)))
;; We need to do something special for 64-bit integer arguments
;; and results.
(if (or (some #'(lambda (type)
- (and (alien-integer-type-p type)
- (> (sb!alien::alien-integer-type-bits type) 32)))
- arg-types)
- (and (alien-integer-type-p result-type)
- (> (sb!alien::alien-integer-type-bits result-type) 32)))
- (collect ((new-args) (lambda-vars) (new-arg-types))
- (dolist (type arg-types)
- (let ((arg (gensym)))
- (lambda-vars arg)
- (cond ((and (alien-integer-type-p type)
- (> (sb!alien::alien-integer-type-bits type) 32))
- ;; 64-bit long long types are stored in
- ;; consecutive locations, most significant word
- ;; first (big-endian).
- (new-args `(ash ,arg -32))
- (new-args `(logand ,arg #xffffffff))
- (if (alien-integer-type-signed type)
- (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- (t
- (new-args arg)
- (new-arg-types type)))))
- (cond ((and (alien-integer-type-p result-type)
- (> (sb!alien::alien-integer-type-bits result-type) 32))
- (let ((new-result-type
- (let ((sb!alien::*values-type-okay* t))
- (parse-alien-type
- (if (alien-integer-type-signed result-type)
- '(values (signed 32) (unsigned 32))
- '(values (unsigned 32) (unsigned 32)))
- (sb!kernel:make-null-lexenv)))))
- `(lambda (function type ,@(lambda-vars))
- (declare (ignore type))
- (multiple-value-bind (high low)
- (%alien-funcall function
- ',(make-alien-fun-type
- :arg-types (new-arg-types)
- :result-type new-result-type)
- ,@(new-args))
- (logior low (ash high 32))))))
- (t
- `(lambda (function type ,@(lambda-vars))
- (declare (ignore type))
- (%alien-funcall function
- ',(make-alien-fun-type
- :arg-types (new-arg-types)
- :result-type result-type)
- ,@(new-args))))))
- (sb!c::give-up-ir1-transform))))
+ (and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32)))
+ arg-types)
+ (and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32)))
+ (collect ((new-args) (lambda-vars) (new-arg-types))
+ (dolist (type arg-types)
+ (let ((arg (gensym)))
+ (lambda-vars arg)
+ (cond ((and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32))
+ ;; 64-bit long long types are stored in
+ ;; consecutive locations, most significant word
+ ;; first (big-endian).
+ (new-args `(ash ,arg -32))
+ (new-args `(logand ,arg #xffffffff))
+ (if (alien-integer-type-signed type)
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ (t
+ (new-args arg)
+ (new-arg-types type)))))
+ (cond ((and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32))
+ (let ((new-result-type
+ (let ((sb!alien::*values-type-okay* t))
+ (parse-alien-type
+ (if (alien-integer-type-signed result-type)
+ '(values (signed 32) (unsigned 32))
+ '(values (unsigned 32) (unsigned 32)))
+ (sb!kernel:make-null-lexenv)))))
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (multiple-value-bind (high low)
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type new-result-type)
+ ,@(new-args))
+ (logior low (ash high 32))))))
+ (t
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type result-type)
+ ,@(new-args))))))
+ (sb!c::give-up-ir1-transform))))
(define-vop (foreign-symbol-sap)
(:translate foreign-symbol-sap)
(define-vop (call-out)
(:args (function :scs (sap-reg) :target cfunc)
- (args :more t))
+ (args :more t))
(:results (results :more t))
(:ignore args results)
(:save-p t)
(:temporary (:sc any-reg :offset cfunc-offset
- :from (:argument 0) :to (:result 0)) cfunc)
+ :from (:argument 0) :to (:result 0)) cfunc)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:scs (non-descriptor-reg)) temp)
(:vop-var vop)
(:generator 0
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(inst lr temp (make-fixup "call_into_c" :foreign))
(inst mtctr temp)
(move cfunc function)
(inst bctrl)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))))
+ (load-stack-tn cur-nfp nfp-save)))))
(define-vop (alloc-number-stack-space)
;; NUMBER-STACK-DISPLACEMENT twice here. Weird. -- CSR,
;; 2003-08-20
(let ((delta (- (logandc2 (+ amount number-stack-displacement
- +stack-alignment-bytes+)
- +stack-alignment-bytes+))))
- (cond ((>= delta (ash -1 16))
- (inst stwu nsp-tn nsp-tn delta))
- (t
- (inst lr temp delta)
- (inst stwux nsp-tn nsp-tn temp)))))
+ +stack-alignment-bytes+)
+ +stack-alignment-bytes+))))
+ (cond ((>= delta (ash -1 16))
+ (inst stwu nsp-tn nsp-tn delta))
+ (t
+ (inst lr temp delta)
+ (inst stwux nsp-tn nsp-tn temp)))))
(unless (location= result nsp-tn)
;; They are only location= when the result tn was allocated by
;; make-call-out-tns above, which takes the number-stack-displacement
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount number-stack-displacement
- +stack-alignment-bytes+)
- +stack-alignment-bytes+)))
- (cond ((< delta (ash 1 16))
- (inst addi nsp-tn nsp-tn delta))
- (t
- (inst lwz nsp-tn nsp-tn 0)))))))
+ +stack-alignment-bytes+)
+ +stack-alignment-bytes+)))
+ (cond ((< delta (ash 1 16))
+ (inst addi nsp-tn nsp-tn delta))
+ (t
+ (inst lwz nsp-tn nsp-tn 0)))))))
#-sb-xc-host
(progn
;;; callback wrapper
(defun alien-callback-assembler-wrapper (index result-type argument-types)
(flet ((make-gpr (n)
- (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
- (make-fpr (n)
- (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset n)))
+ (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
+ (make-fpr (n)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset n)))
(let* ((segment (make-segment)))
- (assemble (segment)
- ;; To save our arguments, we follow the algorithm sketched in the
- ;; "PowerPC Calling Conventions" section of that document.
- (let ((words-processed 0)
- (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
- (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))
- (stack-pointer (make-gpr 1)))
- (labels ((out-of-registers-error ()
- (error "Too many arguments in callback"))
- (save-arg (type words)
- (let ((integerp (not (alien-float-type-p type)))
- (offset (+ (* words-processed n-word-bytes)
- n-foreign-linkage-area-bytes)))
- (cond (integerp
- (loop repeat words
- for gpr = (pop gprs)
- do
- (if gpr
- (inst stw gpr stack-pointer offset)
- (out-of-registers-error))
- (incf words-processed)))
- ;; The handling of floats is a little ugly
- ;; because we hard-code the number of words
- ;; for single- and double-floats.
- ((alien-single-float-type-p type)
- (pop gprs)
- (let ((fpr (pop fprs)))
- (if fpr
- (inst stfs fpr stack-pointer offset)
- (out-of-registers-error)))
- (incf words-processed))
- ((alien-double-float-type-p type)
- (setf gprs (cddr gprs))
- (let ((fpr (pop fprs)))
- (if fpr
- (inst stfd fpr stack-pointer offset)
- (out-of-registers-error)))
- (incf words-processed 2))
- (t
- (bug "Unknown alien floating point type: ~S" type))))))
- (mapc #'save-arg
- argument-types
- (mapcar (lambda (arg)
- (ceiling (alien-type-bits arg) n-word-bits))
- argument-types))))
- ;; Set aside room for the return area just below sp, then
- ;; actually call funcall3: funcall3 (call-alien-function,
- ;; index, args, return-area)
- ;;
- ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
- ;; because they're word-aligned. Kinda gross, but hey ...
- (let* ((n-return-area-words
- (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
- (n-return-area-bytes (* n-return-area-words n-word-bytes))
- ;; FIXME: magic constant, and probably n-args-bytes
- (args-size (* 3 n-word-bytes))
- ;; FIXME: n-frame-bytes?
- (frame-size
- (+ n-foreign-linkage-area-bytes n-return-area-bytes args-size)))
- (destructuring-bind (sp r0 arg1 arg2 arg3 arg4)
- (mapcar #'make-gpr '(1 0 3 4 5 6))
- (flet ((load-address-into (reg addr)
- (let ((high (ldb (byte 16 16) addr))
- (low (ldb (byte 16 0) addr)))
- (inst li reg high)
- (inst slwi reg reg 16)
- (inst ori reg reg low))))
- ;; Setup the args
- (load-address-into
- arg1 (get-lisp-obj-address #'enter-alien-callback))
- (inst li arg2 (fixnumize index))
- (inst addi arg3 sp n-foreign-linkage-area-bytes)
- ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
- ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
- ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
- ;; --NS 2005-06-11
- (inst addi arg4 sp (- n-return-area-bytes))
- ;; FIXME! FIXME FIXME: What does this FIXME refer to?
- ;; Save sp, setup the frame
- (inst mflr r0)
- (inst stw r0 sp (* 2 n-word-bytes)) ; FIXME: magic constant
- (inst stwu sp sp (- frame-size))
- ;; Make the call
- (load-address-into r0 (foreign-symbol-address "funcall3"))
- (inst mtlr r0)
- (inst blrl))
- ;; We're back! Restore sp and lr, load the return value from just
- ;; under sp, and return.
- (inst lwz sp sp 0)
- (inst lwz r0 sp (* 2 n-word-bytes))
- (inst mtlr r0)
- (loop with gprs = (mapcar #'make-gpr '(3 4))
- repeat n-return-area-words
- for gpr = (pop gprs)
- for offset downfrom (- n-word-bytes) by n-word-bytes
- do
- (unless gpr
- (bug "Out of return registers in alien-callback trampoline."))
- (inst lwz gpr sp offset))
- (inst blr))))
- (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))))))
-
\ No newline at end of file
+ (assemble (segment)
+ ;; To save our arguments, we follow the algorithm sketched in the
+ ;; "PowerPC Calling Conventions" section of that document.
+ (let ((words-processed 0)
+ (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
+ (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))
+ (stack-pointer (make-gpr 1)))
+ (labels ((out-of-registers-error ()
+ (error "Too many arguments in callback"))
+ (save-arg (type words)
+ (let ((integerp (not (alien-float-type-p type)))
+ (offset (+ (* words-processed n-word-bytes)
+ n-foreign-linkage-area-bytes)))
+ (cond (integerp
+ (loop repeat words
+ for gpr = (pop gprs)
+ do
+ (if gpr
+ (inst stw gpr stack-pointer offset)
+ (out-of-registers-error))
+ (incf words-processed)))
+ ;; The handling of floats is a little ugly
+ ;; because we hard-code the number of words
+ ;; for single- and double-floats.
+ ((alien-single-float-type-p type)
+ (pop gprs)
+ (let ((fpr (pop fprs)))
+ (if fpr
+ (inst stfs fpr stack-pointer offset)
+ (out-of-registers-error)))
+ (incf words-processed))
+ ((alien-double-float-type-p type)
+ (setf gprs (cddr gprs))
+ (let ((fpr (pop fprs)))
+ (if fpr
+ (inst stfd fpr stack-pointer offset)
+ (out-of-registers-error)))
+ (incf words-processed 2))
+ (t
+ (bug "Unknown alien floating point type: ~S" type))))))
+ (mapc #'save-arg
+ argument-types
+ (mapcar (lambda (arg)
+ (ceiling (alien-type-bits arg) n-word-bits))
+ argument-types))))
+ ;; Set aside room for the return area just below sp, then
+ ;; actually call funcall3: funcall3 (call-alien-function,
+ ;; index, args, return-area)
+ ;;
+ ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
+ ;; because they're word-aligned. Kinda gross, but hey ...
+ (let* ((n-return-area-words
+ (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
+ (n-return-area-bytes (* n-return-area-words n-word-bytes))
+ ;; FIXME: magic constant, and probably n-args-bytes
+ (args-size (* 3 n-word-bytes))
+ ;; FIXME: n-frame-bytes?
+ (frame-size
+ (+ n-foreign-linkage-area-bytes n-return-area-bytes args-size)))
+ (destructuring-bind (sp r0 arg1 arg2 arg3 arg4)
+ (mapcar #'make-gpr '(1 0 3 4 5 6))
+ (flet ((load-address-into (reg addr)
+ (let ((high (ldb (byte 16 16) addr))
+ (low (ldb (byte 16 0) addr)))
+ (inst li reg high)
+ (inst slwi reg reg 16)
+ (inst ori reg reg low))))
+ ;; Setup the args
+ (load-address-into
+ arg1 (get-lisp-obj-address #'enter-alien-callback))
+ (inst li arg2 (fixnumize index))
+ (inst addi arg3 sp n-foreign-linkage-area-bytes)
+ ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
+ ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
+ ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
+ ;; --NS 2005-06-11
+ (inst addi arg4 sp (- n-return-area-bytes))
+ ;; FIXME! FIXME FIXME: What does this FIXME refer to?
+ ;; Save sp, setup the frame
+ (inst mflr r0)
+ (inst stw r0 sp (* 2 n-word-bytes)) ; FIXME: magic constant
+ (inst stwu sp sp (- frame-size))
+ ;; Make the call
+ (load-address-into r0 (foreign-symbol-address "funcall3"))
+ (inst mtlr r0)
+ (inst blrl))
+ ;; We're back! Restore sp and lr, load the return value from just
+ ;; under sp, and return.
+ (inst lwz sp sp 0)
+ (inst lwz r0 sp (* 2 n-word-bytes))
+ (inst mtlr r0)
+ (loop with gprs = (mapcar #'make-gpr '(3 4))
+ repeat n-return-area-words
+ for gpr = (pop gprs)
+ for offset downfrom (- n-word-bytes) by n-word-bytes
+ do
+ (unless gpr
+ (bug "Out of return registers in alien-callback trampoline."))
+ (inst lwz gpr sp offset))
+ (inst blr))))
+ (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))))))
(declare (type unsigned-byte n))
(if (< n register-arg-count)
(make-wired-tn *backend-t-primitive-type* register-arg-scn
- (elt *register-arg-offsets* n))
+ (elt *register-arg-offsets* n))
(make-wired-tn *backend-t-primitive-type* control-stack-arg-scn n)))
(specify-save-tn
(physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
(make-wired-tn *fixnum-primitive-type*
- control-stack-arg-scn
- ocfp-save-offset)))
+ control-stack-arg-scn
+ ocfp-save-offset)))
(!def-vm-support-routine make-return-pc-save-location (env)
(specify-save-tn
(physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env)
(make-wired-tn *backend-t-primitive-type*
- control-stack-arg-scn
- lra-save-offset)))
+ control-stack-arg-scn
+ lra-save-offset)))
;;; Make a TN for the standard argument count passing location. We
;;; only need to make the standard location, since a count is never
;;; 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 push
(declare (type component component))
(dotimes (i code-constants-offset)
(vector-push-extend nil
- (ir2-component-constants (component-info component))))
+ (ir2-component-constants (component-info component))))
(values))
\f
;;;; Frame hackery:
-;;; this is the first function in this file that differs materially from
+;;; this is the first function in this file that differs materially from
;;; ../alpha/call.lisp
(defun bytes-needed-for-non-descriptor-stack-frame ()
(logandc2 (+ +stack-alignment-bytes+ number-stack-displacement
- (* (sb-allocated-size 'non-descriptor-stack) n-word-bytes))
- +stack-alignment-bytes+))
+ (* (sb-allocated-size 'non-descriptor-stack) n-word-bytes))
+ +stack-alignment-bytes+))
;;; Used for setting up the Old-FP in local call.
(:generator 1
(let ((nfp (current-nfp-tn vop)))
(when nfp
- (inst addi val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
+ (inst addi val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
(define-vop (xep-allocate-frame)
(:info start-lab copy-more-arg-follows)
;; on the stack" so that GC sees it. No idea what "it" is -dan 20020110
;; Build our stack frames.
(inst addi csp-tn cfp-tn
- (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
(let ((nfp-tn (current-nfp-tn vop)))
(when nfp-tn
- (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame)))
- (when (> nbytes number-stack-displacement)
- (inst stwu nsp-tn nsp-tn (- nbytes))
- (inst addi nfp-tn nsp-tn number-stack-displacement)))))
+ (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame)))
+ (when (> nbytes number-stack-displacement)
+ (inst stwu nsp-tn nsp-tn (- nbytes))
+ (inst addi nfp-tn nsp-tn number-stack-displacement)))))
(trace-table-entry trace-table-normal)))
(define-vop (allocate-frame)
(:results (res :scs (any-reg))
- (nfp :scs (any-reg)))
+ (nfp :scs (any-reg)))
(:info callee)
(:generator 2
(trace-table-entry trace-table-fun-prologue)
(move res csp-tn)
(inst addi csp-tn csp-tn
- (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
(when (ir2-physenv-number-stack-p callee)
(let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame)))
- (when (> nbytes number-stack-displacement)
- (inst stwu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame)))
- (inst addi nfp nsp-tn number-stack-displacement))))
+ (when (> nbytes number-stack-displacement)
+ (inst stwu nsp-tn nsp-tn (- (bytes-needed-for-non-descriptor-stack-frame)))
+ (inst addi nfp nsp-tn number-stack-displacement))))
(trace-table-entry trace-table-normal)))
;;; Allocate a partial frame for passing stack arguments in a full call. Nargs
;;;
;;; The general-case code looks like this:
#|
- b regs-defaulted ; Skip if MVs
- nop
+ b regs-defaulted ; Skip if MVs
+ nop
- move a1 null-tn ; Default register values
- ...
- loadi nargs 1 ; Force defaulting of stack values
- move old-fp csp ; Set up args for SP resetting
+ move a1 null-tn ; Default register values
+ ...
+ loadi nargs 1 ; Force defaulting of stack values
+ move old-fp csp ; Set up args for SP resetting
regs-defaulted
- subcc temp nargs register-arg-count
+ subcc temp nargs register-arg-count
- b :lt default-value-7 ; jump to default code
- loadw move-temp ocfp-tn 6 ; Move value to correct location.
+ b :lt default-value-7 ; jump to default code
+ loadw move-temp ocfp-tn 6 ; Move value to correct location.
subcc temp 1
- store-stack-tn val4-tn move-temp
+ store-stack-tn val4-tn move-temp
- b :lt default-value-8
- loadw move-temp ocfp-tn 7
+ b :lt default-value-8
+ loadw move-temp ocfp-tn 7
subcc temp 1
- store-stack-tn val5-tn move-temp
+ store-stack-tn val5-tn move-temp
- ...
+ ...
defaulting-done
- move csp ocfp ; Reset SP.
+ move csp ocfp ; Reset SP.
<end of code>
<elsewhere>
default-value-7
- store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack)
+ store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack)
default-value-8
- store-stack-tn val5-tn null-tn ; Nil out 8'th value.
+ store-stack-tn val5-tn null-tn ; Nil out 8'th value.
- ...
+ ...
- br defaulting-done
+ br defaulting-done
nop
|#
;;; differences from alpha: (1) alpha tests for lra-label before
-;;; compute-code-from-lra and skips if nil. (2) loop termination is
+;;; compute-code-from-lra and skips if nil. (2) loop termination is
;;; different when clearing stack defaults
(defun default-unknown-values (vop values nvals move-temp temp lra-label)
(declare (type (or tn-ref null) values)
- (type unsigned-byte nvals) (type tn move-temp temp))
+ (type unsigned-byte nvals) (type tn move-temp temp))
(if (<= nvals 1)
(progn
- (sb!assem:without-scheduling ()
- (note-this-location vop :single-value-return)
- (move csp-tn ocfp-tn)
- (inst nop))
- (inst compute-code-from-lra code-tn code-tn lra-label temp))
+ (sb!assem:without-scheduling ()
+ (note-this-location vop :single-value-return)
+ (move csp-tn ocfp-tn)
+ (inst nop))
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))
(let ((regs-defaulted (gen-label))
- (defaulting-done (gen-label))
- (default-stack-vals (gen-label)))
- ;; Branch off to the MV case.
- (sb!assem:without-scheduling ()
- (note-this-location vop :unknown-return)
- (if (> nvals register-arg-count)
- (inst addic. temp nargs-tn (- (fixnumize register-arg-count)))
- (move csp-tn ocfp-tn))
- (inst b regs-defaulted))
-
- ;; Do the single value case.
- (do ((i 1 (1+ i))
- (val (tn-ref-across values) (tn-ref-across val)))
- ((= i (min nvals register-arg-count)))
- (move (tn-ref-tn val) null-tn))
- (when (> nvals register-arg-count)
- (move ocfp-tn csp-tn)
- (inst b default-stack-vals))
-
- (emit-label regs-defaulted)
- (when (> nvals register-arg-count)
- (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 lwz move-temp ocfp-tn (* i n-word-bytes))
- (inst ble default-lab)
- (inst addic. temp temp (- (fixnumize 1)))
- (store-stack-tn tn move-temp)))
-
- (emit-label defaulting-done)
- (move csp-tn ocfp-tn)
-
- (let ((defaults (defaults)))
- (when defaults
- (assemble (*elsewhere*)
- (emit-label default-stack-vals)
- (trace-table-entry trace-table-fun-prologue)
- (do ((remaining defaults (cdr remaining)))
- ((null remaining))
- (let ((def (car remaining)))
- (emit-label (car def))
- (store-stack-tn (cdr def) null-tn)))
- (inst b defaulting-done)
- (trace-table-entry trace-table-normal))))))
-
- (inst compute-code-from-lra code-tn code-tn lra-label temp)))
+ (defaulting-done (gen-label))
+ (default-stack-vals (gen-label)))
+ ;; Branch off to the MV case.
+ (sb!assem:without-scheduling ()
+ (note-this-location vop :unknown-return)
+ (if (> nvals register-arg-count)
+ (inst addic. temp nargs-tn (- (fixnumize register-arg-count)))
+ (move csp-tn ocfp-tn))
+ (inst b regs-defaulted))
+
+ ;; Do the single value case.
+ (do ((i 1 (1+ i))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i (min nvals register-arg-count)))
+ (move (tn-ref-tn val) null-tn))
+ (when (> nvals register-arg-count)
+ (move ocfp-tn csp-tn)
+ (inst b default-stack-vals))
+
+ (emit-label regs-defaulted)
+ (when (> nvals register-arg-count)
+ (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 lwz move-temp ocfp-tn (* i n-word-bytes))
+ (inst ble default-lab)
+ (inst addic. temp temp (- (fixnumize 1)))
+ (store-stack-tn tn move-temp)))
+
+ (emit-label defaulting-done)
+ (move csp-tn ocfp-tn)
+
+ (let ((defaults (defaults)))
+ (when defaults
+ (assemble (*elsewhere*)
+ (emit-label default-stack-vals)
+ (trace-table-entry trace-table-fun-prologue)
+ (do ((remaining defaults (cdr remaining)))
+ ((null remaining))
+ (let ((def (car remaining)))
+ (emit-label (car def))
+ (store-stack-tn (cdr def) null-tn)))
+ (inst b defaulting-done)
+ (trace-table-entry trace-table-normal))))))
+
+ (inst compute-code-from-lra code-tn code-tn lra-label temp)))
(values))
\f
(defun receive-unknown-values (args nargs start count lra-label temp)
(declare (type tn args nargs start count temp))
(let ((variable-values (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(sb!assem:without-scheduling ()
(inst b variable-values)
(inst nop))
-
+
(inst compute-code-from-lra code-tn code-tn lra-label temp)
(inst addi csp-tn csp-tn 4)
(storew (first *register-arg-tns*) csp-tn -1)
(inst subi start csp-tn 4)
(inst li count (fixnumize 1))
-
+
(emit-label done)
-
+
(assemble (*elsewhere*)
(trace-table-entry trace-table-fun-prologue)
(emit-label variable-values)
(inst compute-code-from-lra code-tn code-tn lra-label temp)
(do ((arg *register-arg-tns* (rest arg))
- (i 0 (1+ i)))
- ((null arg))
- (storew (first arg) args i))
+ (i 0 (1+ i)))
+ ((null arg))
+ (storew (first arg) args i))
(move start args)
(move count nargs)
(inst b done)
(start :scs (any-reg))
(count :scs (any-reg)))
(:temporary (:sc descriptor-reg :offset ocfp-offset
- :from :eval :to (:result 0))
- values-start)
+ :from :eval :to (:result 0))
+ values-start)
(:temporary (:sc any-reg :offset nargs-offset
- :from :eval :to (:result 1))
- nvals)
+ :from :eval :to (:result 1))
+ nvals)
(:temporary (:scs (non-descriptor-reg)) temp))
;;; MAYBE-LOAD-STACK-TN.
(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)
(:generator 5
(trace-table-entry trace-table-call-site)
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(emit-return-pc label)
;; alpha uses (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)
;; instead of the clause below
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))
+ (load-stack-tn cur-nfp nfp-save)))
(trace-table-entry trace-table-normal)))
;;; MAYBE-LOAD-STACK-TN.
(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)
(:generator 20
(trace-table-entry trace-table-call-site)
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- ;; alpha doesn't test this before the maybe-load
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ ;; alpha doesn't test this before the maybe-load
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(emit-return-pc label)
(note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count label temp)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))
+ (load-stack-tn cur-nfp nfp-save)))
(trace-table-entry trace-table-normal)))
\f
;;; 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)
(:generator 5
(trace-table-entry trace-table-call-site)
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(emit-return-pc label)
(note-this-location vop :known-return)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))
+ (load-stack-tn cur-nfp nfp-save)))
(trace-table-entry trace-table-normal)))
;;; Return from known values call. We receive the return locations as
;;; MAYBE-LOAD-STACK-TN.
(define-vop (known-return)
(:args (old-fp :target old-fp-temp)
- (return-pc :target return-pc-temp)
- (vals :more t))
+ (return-pc :target return-pc-temp)
+ (vals :more t))
(:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
(:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
(:move-args :known-return)
(move csp-tn cfp-tn)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addi nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (inst addi nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
(move cfp-tn old-fp-temp)
(inst j return-pc-temp (- n-word-bytes other-pointer-lowtag))
(trace-table-entry trace-table-normal)))
;;; replication in defining the cross-product VOPs.
;;;
;;; NAME is the name of the VOP to define.
-;;;
+;;;
;;; NAMED is true if the first argument is a symbol whose global function
;;; definition is to be called.
;;;
(defmacro define-full-call (name named return variable)
(aver (not (and variable (eq return :tail))))
`(define-vop (,name
- ,@(when (eq return :unknown)
- '(unknown-values-receiver)))
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
(:args
,@(unless (eq return :tail)
- '((new-fp :scs (any-reg) :to :eval)))
+ '((new-fp :scs (any-reg) :to :eval)))
,(if named
- '(name :target name-pass)
- '(arg-fun :target lexenv))
-
+ '(name :target name-pass)
+ '(arg-fun :target lexenv))
+
,@(when (eq return :tail)
- '((old-fp :target old-fp-pass)
- (return-pc :target return-pc-pass)))
-
+ '((old-fp :target old-fp-pass)
+ (return-pc :target return-pc-pass)))
+
,@(unless variable '((args :more t :scs (descriptor-reg)))))
,@(when (eq return :fixed)
- '((:results (values :more t))))
-
+ '((:results (values :more t))))
+
(:save-p ,(if (eq return :tail) :compute-only t))
,@(unless (or (eq return :tail) variable)
- '((:move-args :full-call)))
+ '((:move-args :full-call)))
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(unless variable '(nargs))
+ ,@(when (eq return :fixed) '(nvals)))
(:ignore
,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(args)))
(:temporary (:sc descriptor-reg
- :offset ocfp-offset
- :from (:argument 1)
- ,@(unless (eq return :fixed)
- '(:to :eval)))
- old-fp-pass)
+ :offset ocfp-offset
+ :from (:argument 1)
+ ,@(unless (eq return :fixed)
+ '(:to :eval)))
+ old-fp-pass)
(:temporary (:sc descriptor-reg
- :offset lra-offset
- :from (:argument ,(if (eq return :tail) 2 1))
- :to :eval)
- return-pc-pass)
+ :offset lra-offset
+ :from (:argument ,(if (eq return :tail) 2 1))
+ :to :eval)
+ return-pc-pass)
,(if named
- `(:temporary (:sc descriptor-reg :offset fdefn-offset ; -dan
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- name-pass)
- `(:temporary (:sc descriptor-reg :offset lexenv-offset
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- lexenv))
+ `(:temporary (:sc descriptor-reg :offset fdefn-offset ; -dan
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ name-pass)
+ `(:temporary (:sc descriptor-reg :offset lexenv-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ lexenv))
,@(unless named
- '((:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
- function)))
+ '((:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
+ function)))
(:temporary (:sc any-reg :offset nargs-offset :to :eval)
- nargs-pass)
+ nargs-pass)
,@(when variable
- (mapcar #'(lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :to :eval)
- ,name))
- register-arg-names *register-arg-offsets*))
+ (mapcar #'(lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :to :eval)
+ ,name))
+ register-arg-names *register-arg-offsets*))
,@(when (eq return :fixed)
- '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+ '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
,@(unless (eq return :tail)
- '((:temporary (:scs (non-descriptor-reg)) temp)
- (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+ '((:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
(:temporary (:sc interior-reg :offset lip-offset) entry-point)
(:generator ,(+ (if named 5 0)
- (if variable 19 1)
- (if (eq return :tail) 0 10)
- 15
- (if (eq return :unknown) 25 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)
(let* ((cur-nfp (current-nfp-tn vop))
- ,@(unless (eq return :tail)
- '((lra-label (gen-label))))
- (filler
- (remove nil
- (list :load-nargs
- ,@(if (eq return :tail)
- '((unless (location= old-fp old-fp-pass)
- :load-old-fp)
- (unless (location= return-pc
- return-pc-pass)
- :load-return-pc)
- (when cur-nfp
- :frob-nfp))
- '(:comp-lra
- (when cur-nfp
- :frob-nfp)
- :save-fp
- :load-fp))))))
- (flet ((do-next-filler ()
- (let* ((next (pop filler))
- (what (if (consp next) (car next) next)))
- (ecase what
- (:load-nargs
- ,@(if variable
- `((inst sub nargs-pass csp-tn new-fp)
- ,@(let ((index -1))
- (mapcar #'(lambda (name)
- `(loadw ,name new-fp
- ,(incf index)))
- register-arg-names)))
- '((inst lr nargs-pass (fixnumize nargs)))))
- ,@(if (eq return :tail)
- '((:load-old-fp
- (sc-case old-fp
- (any-reg
- (inst mr old-fp-pass old-fp))
- (control-stack
- (loadw old-fp-pass cfp-tn
- (tn-offset old-fp)))))
- (:load-return-pc
- (sc-case return-pc
- (descriptor-reg
- (inst mr return-pc-pass return-pc))
- (control-stack
- (loadw return-pc-pass cfp-tn
- (tn-offset return-pc)))))
- (:frob-nfp
- (inst addi nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
- `((:comp-lra
- (inst compute-lra-from-code
- return-pc-pass code-tn lra-label temp))
- (:frob-nfp
- (store-stack-tn nfp-save cur-nfp))
- (:save-fp
- (inst mr old-fp-pass cfp-tn))
- (:load-fp
- ,(if variable
- '(move cfp-tn new-fp)
- '(if (> nargs register-arg-count)
- (move cfp-tn new-fp)
- (move cfp-tn csp-tn))))))
- ((nil))))))
- ,@(if named
- `((sc-case name
- (descriptor-reg (move name-pass name))
- (control-stack
- (loadw name-pass cfp-tn (tn-offset name))
- (do-next-filler))
- (constant
- (loadw name-pass code-tn (tn-offset name)
- other-pointer-lowtag)
- (do-next-filler)))
- (loadw entry-point name-pass fdefn-raw-addr-slot
- other-pointer-lowtag)
- (do-next-filler))
- `((sc-case arg-fun
- (descriptor-reg (move lexenv arg-fun))
- (control-stack
- (loadw lexenv cfp-tn (tn-offset arg-fun))
- (do-next-filler))
- (constant
- (loadw lexenv code-tn (tn-offset arg-fun)
- other-pointer-lowtag)
- (do-next-filler)))
- (loadw function lexenv closure-fun-slot
- fun-pointer-lowtag)
- (do-next-filler)
- (inst addi entry-point function
- (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag))
- ))
- (loop
- (if filler
- (do-next-filler)
- (return)))
-
- (note-this-location vop :call-site)
- (inst mtctr entry-point)
- ;; this following line is questionable. or else the alpha
- ;; code (which doesn't do it) is questionable
- ;; (inst mr code-tn function)
- (inst bctr))
-
- ,@(ecase return
- (:fixed
- '((emit-return-pc lra-label)
- (default-unknown-values vop values nvals move-temp
- temp lra-label)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:unknown
- '((emit-return-pc lra-label)
- (note-this-location vop :unknown-return)
- (receive-unknown-values values-start nvals start count
- lra-label temp)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:tail)))
+ ,@(unless (eq return :tail)
+ '((lra-label (gen-label))))
+ (filler
+ (remove nil
+ (list :load-nargs
+ ,@(if (eq return :tail)
+ '((unless (location= old-fp old-fp-pass)
+ :load-old-fp)
+ (unless (location= return-pc
+ return-pc-pass)
+ :load-return-pc)
+ (when cur-nfp
+ :frob-nfp))
+ '(:comp-lra
+ (when cur-nfp
+ :frob-nfp)
+ :save-fp
+ :load-fp))))))
+ (flet ((do-next-filler ()
+ (let* ((next (pop filler))
+ (what (if (consp next) (car next) next)))
+ (ecase what
+ (:load-nargs
+ ,@(if variable
+ `((inst sub nargs-pass csp-tn new-fp)
+ ,@(let ((index -1))
+ (mapcar #'(lambda (name)
+ `(loadw ,name new-fp
+ ,(incf index)))
+ register-arg-names)))
+ '((inst lr nargs-pass (fixnumize nargs)))))
+ ,@(if (eq return :tail)
+ '((:load-old-fp
+ (sc-case old-fp
+ (any-reg
+ (inst mr old-fp-pass old-fp))
+ (control-stack
+ (loadw old-fp-pass cfp-tn
+ (tn-offset old-fp)))))
+ (:load-return-pc
+ (sc-case return-pc
+ (descriptor-reg
+ (inst mr return-pc-pass return-pc))
+ (control-stack
+ (loadw return-pc-pass cfp-tn
+ (tn-offset return-pc)))))
+ (:frob-nfp
+ (inst addi nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
+ `((:comp-lra
+ (inst compute-lra-from-code
+ return-pc-pass code-tn lra-label temp))
+ (:frob-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (:save-fp
+ (inst mr old-fp-pass cfp-tn))
+ (:load-fp
+ ,(if variable
+ '(move cfp-tn new-fp)
+ '(if (> nargs register-arg-count)
+ (move cfp-tn new-fp)
+ (move cfp-tn csp-tn))))))
+ ((nil))))))
+ ,@(if named
+ `((sc-case name
+ (descriptor-reg (move name-pass name))
+ (control-stack
+ (loadw name-pass cfp-tn (tn-offset name))
+ (do-next-filler))
+ (constant
+ (loadw name-pass code-tn (tn-offset name)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw entry-point name-pass fdefn-raw-addr-slot
+ other-pointer-lowtag)
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move lexenv arg-fun))
+ (control-stack
+ (loadw lexenv cfp-tn (tn-offset arg-fun))
+ (do-next-filler))
+ (constant
+ (loadw lexenv code-tn (tn-offset arg-fun)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw function lexenv closure-fun-slot
+ fun-pointer-lowtag)
+ (do-next-filler)
+ (inst addi entry-point function
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))
+ ))
+ (loop
+ (if filler
+ (do-next-filler)
+ (return)))
+
+ (note-this-location vop :call-site)
+ (inst mtctr entry-point)
+ ;; this following line is questionable. or else the alpha
+ ;; code (which doesn't do it) is questionable
+ ;; (inst mr code-tn function)
+ (inst bctr))
+
+ ,@(ecase return
+ (:fixed
+ '((emit-return-pc lra-label)
+ (default-unknown-values vop values nvals move-temp
+ temp lra-label)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:unknown
+ '((emit-return-pc lra-label)
+ (note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count
+ lra-label temp)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:tail)))
(trace-table-entry trace-table-normal))))
;; Clear the number stack if anything is there.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addi nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (inst addi nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
+
-
(inst ba (make-fixup 'tail-call-variable :assembly-routine))))
\f
;;; Return a single value using the unknown-values convention.
(define-vop (return-single)
(:args (old-fp :scs (any-reg))
- (return-pc :scs (descriptor-reg))
- (value))
+ (return-pc :scs (descriptor-reg))
+ (value))
(:ignore value)
(:temporary (:scs (interior-reg)) lip)
(:vop-var vop)
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addi nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (inst addi nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
;; Clear the control stack, and restore the frame pointer.
(move csp-tn cfp-tn)
(move cfp-tn old-fp)
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addi nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (inst addi nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
(cond ((= nvals 1)
- ;; Clear the control stack, and restore the frame pointer.
- (move csp-tn cfp-tn)
- (move cfp-tn old-fp)
- ;; Out of here.
- (lisp-return return-pc lip :offset 2))
- (t
- ;; Establish the values pointer and values count.
- (move val-ptr cfp-tn)
- (inst lr nargs (fixnumize nvals))
- ;; restore the frame pointer and clear as much of the control
- ;; stack as possible.
- (move cfp-tn old-fp)
- (inst addi csp-tn val-ptr (* nvals n-word-bytes))
- ;; pre-default any argument register that need it.
- (when (< nvals register-arg-count)
- (dolist (reg (subseq (list a0 a1 a2 a3) nvals))
- (move reg null-tn)))
- ;; And away we go.
- (lisp-return return-pc lip)))
+ ;; Clear the control stack, and restore the frame pointer.
+ (move csp-tn cfp-tn)
+ (move cfp-tn old-fp)
+ ;; Out of here.
+ (lisp-return return-pc lip :offset 2))
+ (t
+ ;; Establish the values pointer and values count.
+ (move val-ptr cfp-tn)
+ (inst lr nargs (fixnumize nvals))
+ ;; restore the frame pointer and clear as much of the control
+ ;; stack as possible.
+ (move cfp-tn old-fp)
+ (inst addi csp-tn val-ptr (* nvals n-word-bytes))
+ ;; pre-default any argument register that need it.
+ (when (< nvals register-arg-count)
+ (dolist (reg (subseq (list a0 a1 a2 a3) nvals))
+ (move reg null-tn)))
+ ;; And away we go.
+ (lisp-return return-pc lip)))
(trace-table-entry trace-table-normal)))
;;; Do unknown-values return of an arbitrary number of values (passed
(let ((not-single (gen-label)))
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
- (when cur-nfp
- (inst addi nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (when cur-nfp
+ (inst addi nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
;; Check for the single case.
(inst cmpwi nvals-arg (fixnumize 1))
(move csp-tn cfp-tn)
(move cfp-tn old-fp-arg)
(lisp-return lra-arg lip :offset 2)
-
+
;; Nope, not the single case.
(emit-label not-single)
(move old-fp old-fp-arg)
;;; Get the lexical environment from its passing location.
(define-vop (setup-closure-environment)
(:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
- :to (:result 0))
- lexenv)
+ :to (:result 0))
+ lexenv)
(:results (closure :scs (descriptor-reg)))
(:info label)
(:ignore label)
(move closure lexenv)))
;;; Copy a more arg from the argument area to the end of the current frame.
-;;; Fixed is the number of non-more arguments.
+;;; Fixed is the number of non-more arguments.
(define-vop (copy-more-arg)
(:temporary (:sc any-reg :offset nl0-offset) result)
(:temporary (:sc any-reg :offset nl1-offset) count)
(:info fixed)
(:generator 20
(let ((loop (gen-label))
- (do-regs (gen-label))
- (done (gen-label)))
+ (do-regs (gen-label))
+ (done (gen-label)))
(when (< fixed register-arg-count)
- ;; Save a pointer to the results so we can fill in register args.
- ;; We don't need this if there are more fixed args than reg args.
- (move result csp-tn))
+ ;; Save a pointer to the results so we can fill in register args.
+ ;; We don't need this if there are more fixed args than reg args.
+ (move result csp-tn))
;; Allocate the space on the stack.
(cond ((zerop fixed)
- (inst cmpwi nargs-tn 0)
- (inst add csp-tn csp-tn nargs-tn)
- (inst beq done))
- (t
- (inst addic. count nargs-tn (- (fixnumize fixed)))
- (inst ble done)
- (inst add csp-tn csp-tn count)))
+ (inst cmpwi nargs-tn 0)
+ (inst add csp-tn csp-tn nargs-tn)
+ (inst beq done))
+ (t
+ (inst addic. count nargs-tn (- (fixnumize fixed)))
+ (inst ble done)
+ (inst add csp-tn csp-tn count)))
(when (< fixed register-arg-count)
- ;; We must stop when we run out of stack args, not when we run out of
- ;; more args.
- (inst addic. count nargs-tn (- (fixnumize register-arg-count)))
- ;; Everything of interest is in registers.
- (inst ble do-regs))
+ ;; We must stop when we run out of stack args, not when we run out of
+ ;; more args.
+ (inst addic. count nargs-tn (- (fixnumize register-arg-count)))
+ ;; Everything of interest is in registers.
+ (inst ble do-regs))
;; Initialize dst to be end of stack.
(move dst csp-tn)
;; Initialize src to be end of args.
(emit-label do-regs)
(when (< fixed register-arg-count)
- ;; Now we have to deposit any more args that showed up in registers.
- (inst subic. count nargs-tn (fixnumize fixed))
- (do ((i fixed (1+ i)))
- ((>= i register-arg-count))
- ;; Don't deposit any more than there are.
- (inst beq done)
- (inst subic. count count (fixnumize 1))
- ;; Store it relative to the pointer saved at the start.
- (storew (nth i *register-arg-tns*) result (- i fixed))))
+ ;; Now we have to deposit any more args that showed up in registers.
+ (inst subic. count nargs-tn (fixnumize fixed))
+ (do ((i fixed (1+ i)))
+ ((>= i register-arg-count))
+ ;; Don't deposit any more than there are.
+ (inst beq done)
+ (inst subic. count count (fixnumize 1))
+ ;; Store it relative to the pointer saved at the start.
+ (storew (nth i *register-arg-tns*) result (- i fixed))))
(emit-label done))))
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
- (count-arg :target count :scs (any-reg)))
+ (count-arg :target count :scs (any-reg)))
(:arg-types * tagged-num)
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
(:node-var node)
(:generator 20
(let* ((enter (gen-label))
- (loop (gen-label))
- (done (gen-label))
- (dx-p (node-stack-allocate-p node))
- (alloc-area-tn (if dx-p csp-tn alloc-tn)))
+ (loop (gen-label))
+ (done (gen-label))
+ (dx-p (node-stack-allocate-p node))
+ (alloc-area-tn (if dx-p csp-tn alloc-tn)))
(move context context-arg)
(move count count-arg)
;; Check to see if there are any arguments.
;; We need to do this atomically.
(pseudo-atomic (pa-flag)
(when dx-p
- (align-csp temp))
+ (align-csp temp))
;; Allocate a cons (2 words) for each item.
(inst clrrwi result alloc-area-tn n-lowtag-bits)
(inst ori result result list-pointer-lowtag)
(emit-label enter)
(loadw temp context)
(inst addi context context n-word-bytes)
-
+
;; Dec count, and if != zero, go back for more.
(inst addic. count count (- (fixnumize 1)))
;; Store the value into the car of the current cons (in the delay
(:arg-types tagged-num (: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
;;; Signal various errors.
(macrolet ((frob (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)))))
(frob arg-count-error invalid-arg-count-error
sb!c::%arg-count-error nargs)
(frob 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)))
+ (value :scs (descriptor-reg any-reg)))
(:info name offset lowtag)
(:ignore name)
(:results)
(:policy :fast-safe)
(:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
- (fdefn :scs (descriptor-reg)))
+ (fdefn :scs (descriptor-reg)))
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg)) type)
(:results (result :scs (descriptor-reg)))
(inst cmpwi type simple-fun-header-widetag)
;;(inst mr lip function)
(inst addi lip function
- (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
+ (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
(inst beq normal-fn)
(inst lr lip (make-fixup "closure_tramp" :foreign))
(emit-label normal-fn)
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
- (symbol :scs (descriptor-reg)))
+ (symbol :scs (descriptor-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:generator 5
(loadw temp symbol symbol-value-slot other-pointer-lowtag)
(:temporary (:scs (descriptor-reg)) symbol value)
(:generator 0
(let ((loop (gen-label))
- (skip (gen-label))
- (done (gen-label)))
+ (skip (gen-label))
+ (done (gen-label)))
(move where arg)
(inst cmpw where bsp-tn)
(inst beq done)
(:arg-types instance (:constant index) *))
(define-vop (instance-index-ref word-index-ref)
- (:policy :fast-safe)
+ (:policy :fast-safe)
(:translate %instance-ref)
(:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types instance positive-fixnum))
(define-vop (instance-index-set word-index-set)
- (:policy :fast-safe)
+ (:policy :fast-safe)
(:translate %instance-set)
(:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types instance positive-fixnum *))
(:translate %raw-instance-ref/word)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:results (value :scs (unsigned-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(:translate %raw-instance-set/word)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
+ (index :scs (any-reg))
(value :scs (unsigned-reg)))
(:arg-types * positive-fixnum unsigned-num)
(:results (result :scs (unsigned-reg)))
(: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)
(:results (value :scs (single-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(: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)
(:results (result :scs (single-reg)))
(:result-types single-float)
(: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)
(:results (value :scs (double-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(: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)
(:results (result :scs (double-reg)))
(:result-types double-float)
(: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)
(:results (value :scs (complex-single-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(: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)
(:results (result :scs (complex-single-reg)))
(:result-types complex-single-float)
(- (* (- instance-slots-offset 2) n-word-bytes)
instance-pointer-lowtag))
(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 stfsx value-real object offset)
(unless (location= result-real value-real)
(inst frsp result-real value-real)))
(inst addi offset offset n-word-bytes)
(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 stfsx value-imag object offset)
(unless (location= result-imag value-imag)
(inst frsp result-imag value-imag)))))
(: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)
(:results (value :scs (complex-double-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(: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)
(:results (result :scs (complex-double-reg)))
(:result-types complex-double-float)
(- (* (- instance-slots-offset 4) n-word-bytes)
instance-pointer-lowtag))
(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 stfdx value-real object offset)
(unless (location= result-real value-real)
(inst fmr result-real value-real)))
(inst addi offset offset (* 2 n-word-bytes))
(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 stfdx value-imag object offset)
(unless (location= result-imag value-imag)
(inst fmr result-imag value-imag)))))
;;; 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)
- :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
;;; Comparison of characters.
(define-vop (character-compare)
(:args (x :scs (character-reg))
- (y :scs (character-reg)))
+ (y :scs (character-reg)))
(:arg-types character character)
(:conditional)
(:info target not-p)
(:translate sb!kernel:stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (offset :scs (any-reg)))
+ (offset :scs (any-reg)))
(:arg-types system-area-pointer positive-fixnum)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:translate sb!kernel:%set-stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (offset :scs (any-reg))
- (value :scs (descriptor-reg) :target result))
+ (offset :scs (any-reg))
+ (value :scs (descriptor-reg) :target result))
(:arg-types system-area-pointer positive-fixnum *)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:variant-vars lowtag)
(:generator 5
(let ((bogus (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(loadw temp thing 0 lowtag)
(inst srwi temp temp n-widetag-bits)
(inst cmpwi temp 0)
(inst slwi temp temp (1- (integer-length n-word-bytes)))
(inst beq bogus)
(unless (= lowtag other-pointer-lowtag)
- (inst addi temp temp (- lowtag other-pointer-lowtag)))
+ (inst addi temp temp (- lowtag other-pointer-lowtag)))
(inst sub code thing temp)
(emit-label done)
(assemble (*elsewhere*)
- (emit-label bogus)
- (move code null-tn)
- (inst b done)))))
+ (emit-label bogus)
+ (move code null-tn)
+ (inst b done)))))
(define-vop (code-from-lra code-from-mumble)
(:translate sb!di::lra-code-header)
(define-move-fun (load-double 2) (vop x y)
((double-stack) (double-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(inst lfd y nfp offset)))
(define-move-fun (store-double 2) (vop x y)
((double-reg) (double-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(inst stfd x nfp offset)))
;;;; Move VOPs:
(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)
+ `(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 fmr y x))))
- (define-move-vop ,vop :move (,sc) (,sc)))))
+ (define-move-vop ,vop :move (,sc) (,sc)))))
(frob single-move single-reg)
(frob double-move double-reg))
(inst stfs x y (- (* data n-word-bytes) other-pointer-lowtag))))))
(macrolet ((frob (name sc &rest args)
- `(progn
- (define-vop (,name move-from-float)
- (:args (x :scs (,sc) :to :save))
- (:results (y :scs (descriptor-reg)))
- (:variant ,@args))
- (define-move-vop ,name :move (,sc) (descriptor-reg)))))
+ `(progn
+ (define-vop (,name move-from-float)
+ (:args (x :scs (,sc) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:variant ,@args))
+ (define-move-vop ,name :move (,sc) (descriptor-reg)))))
(frob move-from-single single-reg
nil single-float-size single-float-widetag single-float-value-slot)
(frob move-from-double double-reg
t double-float-size double-float-widetag double-float-value-slot))
(macrolet ((frob (name sc double-p value)
- `(progn
- (define-vop (,name)
- (:args (x :scs (descriptor-reg)))
- (:results (y :scs (,sc)))
- (:note "pointer to float coercion")
- (:generator 2
- (inst ,(if double-p 'lfd 'lfs) y x
- (- (* ,value n-word-bytes) other-pointer-lowtag))))
- (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (,sc)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ (inst ,(if double-p 'lfd 'lfs) y x
+ (- (* ,value n-word-bytes) other-pointer-lowtag))))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-single single-reg nil single-float-value-slot)
(frob move-to-double double-reg t double-float-value-slot))
(macrolet ((frob (name sc stack-sc double-p)
- `(progn
- (define-vop (,name)
- (:args (x :scs (,sc) :target y)
- (nfp :scs (any-reg)
- :load-if (not (sc-is y ,sc))))
- (:results (y))
- (:note "float arg move")
- (:generator ,(if double-p 2 1)
- (sc-case y
- (,sc
- (unless (location= x y)
- (inst fmr y x)))
- (,stack-sc
- (let ((offset (* (tn-offset y) n-word-bytes)))
- (inst ,(if double-p 'stfd 'stfs) x nfp offset))))))
- (define-move-vop ,name :move-arg
- (,sc descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (nfp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "float arg move")
+ (:generator ,(if double-p 2 1)
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (inst fmr y x)))
+ (,stack-sc
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ (inst ,(if double-p 'stfd 'stfs) x nfp offset))))))
+ (define-move-vop ,name :move-arg
+ (,sc descriptor-reg) (,sc)))))
(frob move-single-float-arg single-reg single-stack nil)
(frob move-double-float-arg double-reg double-stack t))
(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))))
(define-move-fun (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(let ((real-tn (complex-single-reg-real-tn y)))
(inst lfs real-tn nfp offset))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(define-move-fun (store-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(let ((real-tn (complex-single-reg-real-tn x)))
(inst stfs real-tn nfp offset))
(let ((imag-tn (complex-single-reg-imag-tn x)))
(define-move-fun (load-complex-double 4) (vop x y)
((complex-double-stack) (complex-double-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(let ((real-tn (complex-double-reg-real-tn y)))
(inst lfd real-tn nfp offset))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(define-move-fun (store-complex-double 4) (vop x y)
((complex-double-reg) (complex-double-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(let ((real-tn (complex-double-reg-real-tn x)))
(inst stfd real-tn nfp offset))
(let ((imag-tn (complex-double-reg-imag-tn x)))
;;;
(define-vop (complex-single-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))))
(:note "complex single float move")
(:generator 0
;; 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-single-reg-real-tn x))
- (y-real (complex-single-reg-real-tn y)))
- (inst fmr y-real x-real))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmr y-real x-real))
(let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst fmr y-imag x-imag)))))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmr y-imag x-imag)))))
;;;
(define-move-vop complex-single-move :move
(complex-single-reg) (complex-single-reg))
(define-vop (complex-double-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))))
(:note "complex double float move")
(:generator 0
;; 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)))
- (inst fmr y-real x-real))
+ (y-real (complex-double-reg-real-tn y)))
+ (inst fmr y-real x-real))
(let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (inst fmr y-imag x-imag)))))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fmr y-imag x-imag)))))
;;;
(define-move-vop complex-double-move :move
(complex-double-reg) (complex-double-reg))
(:note "complex single float to pointer coercion")
(:generator 13
(with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag
- complex-single-float-size)
+ complex-single-float-size)
(let ((real-tn (complex-single-reg-real-tn x)))
(inst stfs real-tn y (- (* complex-single-float-real-slot
n-word-bytes)
(:note "complex double float to pointer coercion")
(:generator 13
(with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag
- complex-double-float-size)
+ complex-double-float-size)
(let ((real-tn (complex-double-reg-real-tn x)))
(inst stfd real-tn y (- (* complex-double-float-real-slot
n-word-bytes)
(:generator 2
(let ((real-tn (complex-single-reg-real-tn y)))
(inst lfs real-tn x (- (* complex-single-float-real-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(inst lfs imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
(define-move-vop move-to-complex-single :move
(descriptor-reg) (complex-single-reg))
(:generator 2
(let ((real-tn (complex-double-reg-real-tn y)))
(inst lfd real-tn x (- (* complex-double-float-real-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(inst lfd imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
(define-move-vop move-to-complex-double :move
(descriptor-reg) (complex-double-reg))
;;;
(define-vop (move-complex-single-float-arg)
(:args (x :scs (complex-single-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
(:results (y))
(:note "complex single-float arg move")
(:generator 1
(sc-case y
(complex-single-reg
(unless (location= x y)
- (let ((x-real (complex-single-reg-real-tn x))
- (y-real (complex-single-reg-real-tn y)))
- (inst fmr y-real x-real))
- (let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst fmr y-imag x-imag))))
+ (let ((x-real (complex-single-reg-real-tn x))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmr y-real x-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmr y-imag x-imag))))
(complex-single-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-single-reg-real-tn x)))
- (inst stfs real-tn nfp offset))
- (let ((imag-tn (complex-single-reg-imag-tn x)))
- (inst stfs imag-tn nfp (+ offset n-word-bytes))))))))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst stfs real-tn nfp offset))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst stfs imag-tn nfp (+ offset n-word-bytes))))))))
(define-move-vop move-complex-single-float-arg :move-arg
(complex-single-reg descriptor-reg) (complex-single-reg))
(define-vop (move-complex-double-float-arg)
(:args (x :scs (complex-double-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
(:results (y))
(:note "complex double-float arg move")
(:generator 2
(sc-case y
(complex-double-reg
(unless (location= x y)
- (let ((x-real (complex-double-reg-real-tn x))
- (y-real (complex-double-reg-real-tn y)))
- (inst fmr y-real x-real))
- (let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (inst fmr y-imag x-imag))))
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (inst fmr y-real x-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fmr y-imag x-imag))))
(complex-double-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-double-reg-real-tn x)))
- (inst stfd real-tn nfp offset))
- (let ((imag-tn (complex-double-reg-imag-tn x)))
- (inst stfd imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (inst stfd real-tn nfp offset))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst stfd imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
(define-move-vop move-complex-double-float-arg :move-arg
(complex-double-reg descriptor-reg) (complex-double-reg))
(:save-p :compute-only))
(macrolet ((frob (name sc ptype)
- `(define-vop (,name float-op)
- (:args (x :scs (,sc))
- (y :scs (,sc)))
- (:results (r :scs (,sc)))
- (:arg-types ,ptype ,ptype)
- (:result-types ,ptype))))
+ `(define-vop (,name float-op)
+ (:args (x :scs (,sc))
+ (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 ((frob (op sinst sname scost dinst dname dcost)
- `(progn
- (define-vop (,sname single-float-op)
- (:translate ,op)
- (:generator ,scost
- (inst ,sinst r x y)))
- (define-vop (,dname double-float-op)
- (:translate ,op)
- (:generator ,dcost
- (inst ,dinst r x y))))))
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,op)
+ (:generator ,scost
+ (inst ,sinst r x y)))
+ (define-vop (,dname double-float-op)
+ (:translate ,op)
+ (:generator ,dcost
+ (inst ,dinst r x y))))))
(frob + fadds +/single-float 2 fadd +/double-float 2)
(frob - fsubs -/single-float 2 fsub -/double-float 2)
(frob * fmuls */single-float 4 fmul */double-float 5)
(frob / fdivs //single-float 12 fdiv //double-float 19))
(macrolet ((frob (name inst translate sc type)
- `(define-vop (,name)
- (:args (x :scs (,sc)))
- (:results (y :scs (,sc)))
- (:translate ,translate)
- (:policy :fast-safe)
- (:arg-types ,type)
- (:result-types ,type)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 1
- (note-this-location vop :internal-error)
- (inst ,inst y x)))))
+ `(define-vop (,name)
+ (:args (x :scs (,sc)))
+ (:results (y :scs (,sc)))
+ (:translate ,translate)
+ (:policy :fast-safe)
+ (:arg-types ,type)
+ (:result-types ,type)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ (inst ,inst y x)))))
(frob abs/single-float fabs abs single-reg single-float)
(frob abs/double-float fabs abs double-reg double-float)
(frob %negate/single-float fneg %negate single-reg single-float)
(inst b? :cr1 (if not-p nope yep) target)))
(macrolet ((frob (name sc ptype)
- `(define-vop (,name float-compare)
- (:args (x :scs (,sc))
- (y :scs (,sc)))
- (:arg-types ,ptype ,ptype))))
+ `(define-vop (,name float-compare)
+ (:args (x :scs (,sc))
+ (y :scs (,sc)))
+ (:arg-types ,ptype ,ptype))))
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float))
(macrolet ((frob (translate yep nope sname dname)
- `(progn
- (define-vop (,sname single-float-compare)
- (:translate ,translate)
- (:variant :single ,yep ,nope))
- (define-vop (,dname double-float-compare)
- (:translate ,translate)
- (:variant :double ,yep ,nope)))))
+ `(progn
+ (define-vop (,sname single-float-compare)
+ (:translate ,translate)
+ (:variant :single ,yep ,nope))
+ (define-vop (,dname double-float-compare)
+ (:translate ,translate)
+ (:variant :double ,yep ,nope)))))
(frob < :lt :ge </single-float </double-float)
(frob > :gt :le >/single-float >/double-float)
(frob = :eq :ne eql/single-float eql/double-float))
;;;; Conversion:
(macrolet ((frob (name translate inst to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (signed-reg)))
- (:temporary (:scs (double-stack)) temp)
+ `(define-vop (,name)
+ (:args (x :scs (signed-reg)))
+ (:temporary (:scs (double-stack)) temp)
(:temporary (:scs (double-reg)) fmagic)
(:temporary (:scs (signed-reg)) rtemp)
- (: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
- (let* ((stack-offset (* (tn-offset temp) n-word-bytes))
+ (: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
+ (let* ((stack-offset (* (tn-offset temp) n-word-bytes))
(nfp-tn (current-nfp-tn vop))
(temp-offset-high (* stack-offset n-word-bytes))
(temp-offset-low (* (1+ stack-offset) n-word-bytes)))
(inst lfd fmagic nfp-tn temp-offset-high)
(inst xor rtemp rtemp x) ; invert sign bit of x : rtemp had #x80000000
(inst stw rtemp nfp-tn temp-offset-low)
- (inst lfd y nfp-tn temp-offset-high)
- (note-this-location vop :internal-error)
- (inst ,inst y y fmagic))))))
+ (inst lfd y nfp-tn temp-offset-high)
+ (note-this-location vop :internal-error)
+ (inst ,inst y y fmagic))))))
(frob %single-float/signed %single-float fsubs single-reg single-float)
(frob %double-float/signed %double-float fsub double-reg double-float))
`(define-vop (,name)
(:args (x :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) temp)
- (:temporary (:scs (double-reg)) fmagic)
- (:temporary (:scs (signed-reg)) rtemp)
+ (:temporary (:scs (double-reg)) fmagic)
+ (:temporary (:scs (signed-reg)) rtemp)
(:results (y :scs (,to-sc)))
(:arg-types unsigned-num)
(:result-types ,to-type)
(frob %double-float/unsigned %double-float fsub 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)))
- (: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)))
+ (: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 frsp
double-reg double-float single-reg single-float)
(frob %double-float/single-float %double-float fmr
single-reg single-float double-reg double-float))
(macrolet ((frob (trans from-sc from-type inst)
- `(define-vop (,(symbolicate trans "/" from-type))
- (:args (x :scs (,from-sc) :target temp))
- (:temporary (:from (:argument 0) :sc single-reg) temp)
- (:temporary (:scs (double-stack)) stack-temp)
- (: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
- (note-this-location vop :internal-error)
- (inst ,inst temp x)
- (inst stfd temp (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst lwz y (current-nfp-tn vop)
- (+ 4 (* (tn-offset stack-temp) n-word-bytes)))))))
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc) :target temp))
+ (:temporary (:from (:argument 0) :sc single-reg) temp)
+ (:temporary (:scs (double-stack)) stack-temp)
+ (: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
+ (note-this-location vop :internal-error)
+ (inst ,inst temp x)
+ (inst stfd temp (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst lwz y (current-nfp-tn vop)
+ (+ 4 (* (tn-offset stack-temp) n-word-bytes)))))))
(frob %unary-truncate single-reg single-float fctiwz)
(frob %unary-truncate double-reg double-float fctiwz)
(frob %unary-round single-reg single-float fctiw)
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
- :load-if (not (sc-is bits signed-stack))))
+ :load-if (not (sc-is bits signed-stack))))
(:results (res :scs (single-reg)
- :load-if (not (sc-is res single-stack))))
+ :load-if (not (sc-is res single-stack))))
(:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
(:temporary (:scs (signed-stack)) stack-temp)
(:arg-types signed-num)
(sc-case bits
(signed-reg
(sc-case res
- (single-reg
- (inst stw bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst lfs res (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
- (single-stack
- (inst stw bits (current-nfp-tn vop)
- (* (tn-offset res) n-word-bytes)))))
+ (single-reg
+ (inst stw bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst lfs res (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (single-stack
+ (inst stw bits (current-nfp-tn vop)
+ (* (tn-offset res) n-word-bytes)))))
(signed-stack
(sc-case res
- (single-reg
- (inst lfs res (current-nfp-tn vop)
- (* (tn-offset bits) n-word-bytes)))
- (single-stack
- (unless (location= bits res)
- (inst lwz temp (current-nfp-tn vop)
- (* (tn-offset bits) n-word-bytes))
- (inst stw temp (current-nfp-tn vop)
- (* (tn-offset res) n-word-bytes)))))))))
+ (single-reg
+ (inst lfs res (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes)))
+ (single-stack
+ (unless (location= bits res)
+ (inst lwz temp (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes))
+ (inst stw temp (current-nfp-tn vop)
+ (* (tn-offset res) n-word-bytes)))))))))
(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)
- :load-if (not (sc-is res double-stack))))
+ :load-if (not (sc-is res double-stack))))
(:temporary (:scs (double-stack)) temp)
(:arg-types signed-num unsigned-num)
(:result-types double-float)
(:vop-var vop)
(:generator 2
(let ((stack-tn (sc-case res
- (double-stack res)
- (double-reg temp))))
+ (double-stack res)
+ (double-reg temp))))
(inst stw hi-bits (current-nfp-tn vop)
- (* (tn-offset stack-tn) n-word-bytes))
+ (* (tn-offset stack-tn) n-word-bytes))
(inst stw lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-tn)) n-word-bytes)))
+ (* (1+ (tn-offset stack-tn)) n-word-bytes)))
(when (sc-is res double-reg)
(inst lfd res (current-nfp-tn vop)
- (* (tn-offset temp) n-word-bytes)))))
+ (* (tn-offset temp) 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)
- :load-if (or (sc-is float descriptor-reg single-stack)
- (not (sc-is bits signed-stack)))))
+ :load-if (or (sc-is float descriptor-reg single-stack)
+ (not (sc-is bits signed-stack)))))
(:temporary (:scs (signed-stack)) stack-temp)
(:arg-types single-float)
(:result-types signed-num)
(sc-case bits
(signed-reg
(sc-case float
- (single-reg
- (inst stfs float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst lwz bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
- (single-stack
- (inst lwz bits (current-nfp-tn vop)
- (* (tn-offset float) n-word-bytes)))
- (descriptor-reg
- (loadw bits float single-float-value-slot other-pointer-lowtag))))
+ (single-reg
+ (inst stfs float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst lwz bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (single-stack
+ (inst lwz bits (current-nfp-tn vop)
+ (* (tn-offset float) n-word-bytes)))
+ (descriptor-reg
+ (loadw bits float single-float-value-slot other-pointer-lowtag))))
(signed-stack
(sc-case float
- (single-reg
- (inst stfs float (current-nfp-tn vop)
- (* (tn-offset bits) n-word-bytes))))))))
+ (single-reg
+ (inst stfs float (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes))))))))
(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 (:scs (double-stack)) stack-temp)
(:arg-types double-float)
(:generator 5
(sc-case float
(double-reg
- (inst stfd float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst lwz hi-bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ (inst stfd float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst lwz hi-bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
(double-stack
- (inst lwz hi-bits (current-nfp-tn vop)
- (* (tn-offset float) n-word-bytes)))
+ (inst lwz hi-bits (current-nfp-tn vop)
+ (* (tn-offset float) n-word-bytes)))
(descriptor-reg
- (loadw hi-bits float double-float-value-slot
- other-pointer-lowtag)))))
+ (loadw hi-bits float 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 (:scs (double-stack)) stack-temp)
(:arg-types double-float)
(sc-case float
(double-reg
(inst stfd float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst lwz lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst lwz lo-bits (current-nfp-tn vop)
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
(double-stack
(inst lwz lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset float)) n-word-bytes)))
+ (* (1+ (tn-offset float)) n-word-bytes)))
(descriptor-reg
(loadw lo-bits float (1+ double-float-value-slot)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
\f
;;;; Float mode hackery:
(define-vop (make-complex-single-float)
(:translate complex)
(:args (real :scs (single-reg) :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 fmr r-real real)))
+ (unless (location= real r-real)
+ (inst fmr r-real real)))
(let ((r-imag (complex-single-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst fmr r-imag imag))))
+ (unless (location= imag r-imag)
+ (inst fmr r-imag imag))))
(complex-single-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (unless (location= real r)
- (inst stfs real nfp offset))
- (inst stfs imag nfp (+ offset n-word-bytes)))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (unless (location= real r)
+ (inst stfs real nfp offset))
+ (inst stfs imag nfp (+ offset n-word-bytes)))))))
(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 fmr r-real real)))
+ (unless (location= real r-real)
+ (inst fmr r-real real)))
(let ((r-imag (complex-double-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst fmr r-imag imag))))
+ (unless (location= imag r-imag)
+ (inst fmr r-imag imag))))
(complex-double-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (unless (location= real r)
- (inst stfd real nfp offset))
- (inst stfd imag nfp (+ offset (* 2 n-word-bytes))))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (unless (location= real r)
+ (inst stfd real nfp offset))
+ (inst stfd imag nfp (+ offset (* 2 n-word-bytes))))))))
(define-vop (complex-single-float-value)
(:args (x :scs (complex-single-reg) :target r
- :load-if (not (sc-is x complex-single-stack))))
+ :load-if (not (sc-is x complex-single-stack))))
(:arg-types complex-single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(sc-case x
(complex-single-reg
(let ((value-tn (ecase slot
- (:real (complex-single-reg-real-tn x))
- (:imag (complex-single-reg-imag-tn x)))))
- (unless (location= value-tn r)
- (inst fmr r value-tn))))
+ (:real (complex-single-reg-real-tn x))
+ (:imag (complex-single-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst fmr r value-tn))))
(complex-single-stack
(inst lfs r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
- (tn-offset x))
- n-word-bytes))))))
+ (tn-offset x))
+ n-word-bytes))))))
(define-vop (realpart/complex-single-float complex-single-float-value)
(:translate realpart)
(define-vop (complex-double-float-value)
(:args (x :scs (complex-double-reg) :target r
- :load-if (not (sc-is x complex-double-stack))))
+ :load-if (not (sc-is x complex-double-stack))))
(:arg-types complex-double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(sc-case x
(complex-double-reg
(let ((value-tn (ecase slot
- (:real (complex-double-reg-real-tn x))
- (:imag (complex-double-reg-imag-tn x)))))
- (unless (location= value-tn r)
- (inst fmr r value-tn))))
+ (:real (complex-double-reg-real-tn x))
+ (:imag (complex-double-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst fmr r value-tn))))
(complex-double-stack
(inst lfd r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
- (tn-offset x))
- n-word-bytes))))))
+ (tn-offset x))
+ n-word-bytes))))))
(define-vop (realpart/complex-double-float complex-double-float-value)
(:translate realpart)
;;; delays requested here are not mandatory, so that the assembler
;;; shouldn't fill gaps with NOPs but with real instructions. -- CSR,
;;; 2003-09-08
-#+nil
+#+nil
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf sb!assem:*assem-scheduler-p* t)
(setf sb!assem:*assem-max-locations* 70))
(null null-offset)
(t
(if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
- (tn-offset tn)
- (error "~S isn't a register." tn)))))
+ (tn-offset tn)
+ (error "~S isn't a register." tn)))))
(defun fp-reg-tn-encoding (tn)
(declare (type tn tn))
(tn
(ecase (sb-name (sc-sb (tn-sc loc)))
(immediate-constant
- ;; Can happen if $ZERO or $NULL are passed in.
- nil)
+ ;; Can happen if $ZERO or $NULL are passed in.
+ nil)
(registers
- (unless (zerop (tn-offset loc))
- (tn-offset loc)))
+ (unless (zerop (tn-offset loc))
+ (tn-offset loc)))
(float-registers
- (+ (tn-offset loc) 32))))
+ (+ (tn-offset loc) 32))))
(symbol
(ecase loc
(:memory 0)
(defparameter reg-symbols
(map 'vector
#'(lambda (name)
- (cond ((null name) nil)
- (t (make-symbol (concatenate 'string "$" name)))))
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "$" name)))))
*register-names*))
(defun maybe-add-notes (regno dstate)
(let* ((inst (sb!disassem::sap-ref-int
- (sb!disassem::dstate-segment-sap dstate)
- (sb!disassem::dstate-cur-offs dstate)
- n-word-bytes
- (sb!disassem::dstate-byte-order dstate)))
- (op (ldb (byte 6 26) inst)))
+ (sb!disassem::dstate-segment-sap dstate)
+ (sb!disassem::dstate-cur-offs dstate)
+ n-word-bytes
+ (sb!disassem::dstate-byte-order dstate)))
+ (op (ldb (byte 6 26) inst)))
(case op
;; lwz
(32
- (when (= regno (ldb (byte 5 16) inst)) ; only for the second
- (case (ldb (byte 5 16) inst)
- ;; reg_CODE
- (19
- (sb!disassem:note-code-constant (ldb (byte 16 0) inst) dstate)))))
+ (when (= regno (ldb (byte 5 16) inst)) ; only for the second
+ (case (ldb (byte 5 16) inst)
+ ;; reg_CODE
+ (19
+ (sb!disassem:note-code-constant (ldb (byte 16 0) inst) dstate)))))
;; addi
(14
(when (= regno null-offset)
- (sb!disassem:maybe-note-nil-indexed-object
- (ldb (byte 16 0) inst) dstate))))))
+ (sb!disassem:maybe-note-nil-indexed-object
+ (ldb (byte 16 0) inst) dstate))))))
(sb!disassem:define-arg-type reg
- :printer
+ :printer
(lambda (value stream dstate)
(declare (type stream stream) (fixnum value))
(let ((regname (aref reg-symbols value)))
(maybe-add-notes value dstate))))
(defparameter float-reg-symbols
- #.(coerce
+ #.(coerce
(loop for n from 0 to 31 collect (make-symbol (format nil "$F~d" n)))
'vector))
(sb!disassem:define-arg-type fp-reg
:printer #'(lambda (value stream dstate)
- (declare (type stream stream) (fixnum value))
- (let ((regname (aref float-reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'float-registers
- regname
- dstate))))
+ (declare (type stream stream) (fixnum value))
+ (let ((regname (aref float-reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'float-registers
+ regname
+ dstate))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter bo-kind-names
(if error-p (error "Invalid condition bit specifier : ~s" enc))))
(defun valid-cr-field-encoding (enc)
- (let* ((field (if (integerp enc)
+ (let* ((field (if (integerp enc)
(and (= enc (logand #x7 enc)))
(position enc cr-field-names))))
(if field
(ash field 2)
(error "Invalid condition register field specifier : ~s" enc))))
-
+
(defun valid-bi-encoding (enc)
(or
- (if (atom enc)
- (if (integerp enc)
+ (if (atom enc)
+ (if (integerp enc)
(and (= enc (logand 31 enc)) enc)
(position enc cr-bit-names))
(+ (valid-cr-field-encoding (car enc))
(sb!disassem:define-arg-type relative-label
:sign-extend t
:use-label #'(lambda (value dstate)
- (declare (type (signed-byte 14) value)
- (type sb!disassem:disassem-state dstate))
- (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
+ (declare (type (signed-byte 14) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter trap-values-alist '((:t . 31) (:lt . 16) (:le . 20) (:eq . 4) (:lng . 6)
(:ge .12) (:ne . 24) (:ng . 20) (:llt . 2) (:f . 0)
(:lle . 6) (:lge . 5) (:lgt . 1) (:lnl . 5))))
-
-
+
+
(defun valid-tcond-encoding (enc)
(or (and (if (integerp enc) (= (logand 31 enc) enc)) enc)
(cdr (assoc enc trap-values-alist))
(error "Unknown trap condition: ~s" enc)))
-
+
(sb!disassem:define-arg-type to-field
:sign-extend nil
:printer #'(lambda (value stream dstate)
(type stream stream)
(type fixnum value))
(princ (or (car (rassoc value trap-values-alist))
- value)
+ value)
stream)))
(defun snarf-error-junk (sap offset &optional length-only)
;; preserving 8 byte alignment
segment 8 2 ; 2^2 is 4 byte alignment. I think
#'(lambda (segment posn magic-value)
- (let ((delta (ash (- (label-position target posn magic-value) posn)
- -2)))
- (when (typep delta '(signed-byte 14))
- (emit-back-patch segment 4
- #'(lambda (segment posn)
- (emit-b-form-inst
- segment 16 bo bi
- (ash (- (label-position target) posn) -2)
- aa-bit lk-bit)))
- t)))
+ (let ((delta (ash (- (label-position target posn magic-value) posn)
+ -2)))
+ (when (typep delta '(signed-byte 14))
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (emit-b-form-inst
+ segment 16 bo bi
+ (ash (- (label-position target) posn) -2)
+ aa-bit lk-bit)))
+ t)))
#'(lambda (segment posn)
- (declare (ignore posn))
- (let ((bo (logxor 8 bo))) ;; invert the test
- (emit-b-form-inst segment 16 bo bi
- 2 ; skip over next instruction
- 0 0)
- (emit-back-patch segment 4
- #'(lambda (segment posn)
- (declare (ignore posn))
- (emit-i-form-branch segment target lk-p)))))
+ (declare (ignore posn))
+ (let ((bo (logxor 8 bo))) ;; invert the test
+ (emit-b-form-inst segment 16 bo bi
+ 2 ; skip over next instruction
+ 0 0)
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (declare (ignore posn))
+ (emit-i-form-branch segment target lk-p)))))
))))
-
+
; non-absolute I-form: B, BL.
(emit-i-form-inst segment 18 0 0 lk-bit))
(label
(emit-back-patch segment 4
- #'(lambda (segment posn)
- (emit-i-form-inst
+ #'(lambda (segment posn)
+ (emit-i-form-inst
segment
18
(ash (- (label-position target) posn) -2)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter jump-printer
#'(lambda (value stream dstate)
- (let ((addr (ash value 2)))
- (sb!disassem:maybe-note-assembler-routine addr t dstate)
- (write addr :base 16 :radix t :stream stream)))))
+ (let ((addr (ash value 2)))
+ (sb!disassem:maybe-note-assembler-routine addr t dstate)
+ (write addr :base 16 :radix t :stream stream)))))
\f
(xo26-30 :field ,(ppc-byte 26 30) :sign-extend nil)))
-
+
(sb!disassem:define-instruction-format (instr 32)
(op :field (byte 6 26))
(other :field (byte 26 0)))
(macrolet ((def-ppc-iformat ((name &optional default-printer) &rest specs)
- (flet ((specname-field (specname)
+ (flet ((specname-field (specname)
(or (assoc specname *ppc-field-specs-alist*)
(error "Unknown ppc instruction field spec ~s" specname))))
(labels ((spec-field (spec)
(cons (car spec)
(cdr (specname-field (cadr spec)))))))
(collect ((field (list '(op :field (byte 6 26)))))
- (dolist (spec specs)
+ (dolist (spec specs)
(field (spec-field spec)))
`(sb!disassem:define-instruction-format (,name 32 ,@(if default-printer `(:default-printer ,default-printer)))
,@(field)))))))
-(def-ppc-iformat (i '(:name :tab li))
+(def-ppc-iformat (i '(:name :tab li))
li aa lk)
-(def-ppc-iformat (i-abs '(:name :tab li-abs))
+(def-ppc-iformat (i-abs '(:name :tab li-abs))
li-abs aa lk)
-(def-ppc-iformat (b '(:name :tab bo "," bi "," bd))
+(def-ppc-iformat (b '(:name :tab bo "," bi "," bd))
bo bi bd aa lk)
(def-ppc-iformat (d '(:name :tab rt "," d "(" ra ")"))
(def-ppc-iformat (d-frs '(:name :tab frs "," d "(" ra ")"))
frs ra d)
-
+
\f
;;; There are around ... oh, 28 or so ... variants on the "X" format.
(name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
`(define-instruction ,name (segment rt ra rb)
(:printer xo ((op ,op ) (xo ,xo) (oe ,(if oe-p 1 0)) (rc ,(if rc-p 1 0))))
- (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
+ (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
(writes rt) ,@(if rc-p '((writes :ccr))) ,@(if (or oe-p always-writes-xer) '((writes :xer))) )
(:cost ,cost)
(:delay ,cost)
(:emitter
(emit-xo-form-inst segment ,op
- (reg-tn-encoding rt)
- (reg-tn-encoding ra)
+ (reg-tn-encoding rt)
+ (reg-tn-encoding ra)
(reg-tn-encoding rb)
,(if oe-p 1 0)
,xo
(name op xo rc-p always-reads-xer always-writes-xer cost)
`(define-instruction ,name (segment rt ra rb)
(:printer xo-oe ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
- (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
+ (:dependencies (reads ra) (reads rb) ,@(if always-reads-xer '((reads :xer)))
(writes rt) ,@(if rc-p '((writes :ccr))) ,@(if always-writes-xer '((writes :xer))))
(:cost ,cost)
(:delay ,cost)
(:emitter
(emit-xo-form-inst segment ,op
- (reg-tn-encoding rt)
- (reg-tn-encoding ra)
+ (reg-tn-encoding rt)
+ (reg-tn-encoding ra)
(reg-tn-encoding rb)
0
,xo
`(progn
(define-xo-oe-instruction ,base ,op ,xo nil ,always-reads-xer ,always-writes-xer ,cost)
(define-xo-oe-instruction ,(symbolicate base ".") ,op ,xo t ,always-reads-xer ,always-writes-xer ,cost)))
-
+
(define-xo-a-instruction (name op xo oe-p rc-p always-reads-xer always-writes-xer cost)
`(define-instruction ,name (segment rt ra)
(:printer xo-a ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0)) (oe ,(if oe-p 1 0))))
(:delay ,cost)
(:emitter
(emit-xo-form-inst segment ,op
- (reg-tn-encoding rt)
- (reg-tn-encoding ra)
+ (reg-tn-encoding rt)
+ (reg-tn-encoding ra)
0
(if ,oe-p 1 0)
,xo
(if ,rc-p 1 0)))))
-
+
(define-4-xo-a-instructions (base op xo &key always-reads-xer always-writes-xer (cost 1))
`(progn
(define-xo-a-instruction ,base ,op ,xo nil nil ,always-reads-xer ,always-writes-xer ,cost)
(define-xo-a-instruction ,(symbolicate base ".") ,op ,xo nil t ,always-reads-xer ,always-writes-xer ,cost)
(define-xo-a-instruction ,(symbolicate base "O") ,op ,xo t nil ,always-reads-xer ,always-writes-xer ,cost)
(define-xo-a-instruction ,(symbolicate base "O.") ,op ,xo t t ,always-reads-xer ,always-writes-xer ,cost)))
-
+
(define-x-instruction (name op xo &key (cost 2) other-dependencies)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment rt ra rb)
(:printer x ((op ,op) (xo ,xo)))
(:delay ,cost)
(:cost ,cost)
- (:dependencies (reads ra) (reads rb) (reads :memory) ,@other-reads
+ (:dependencies (reads ra) (reads rb) (reads :memory) ,@other-reads
(writes rt) ,@other-writes)
(:emitter
- (emit-x-form-inst segment ,op
- (reg-tn-encoding rt)
+ (emit-x-form-inst segment ,op
+ (reg-tn-encoding rt)
(reg-tn-encoding ra)
(reg-tn-encoding rb)
,xo
(:printer x-20 ((op ,op) (xo ,xo)))
(:delay ,cost)
(:cost ,cost)
- (:dependencies (reads ra) (reads rb) ,@other-reads
+ (:dependencies (reads ra) (reads rb) ,@other-reads
(writes frt) ,@other-writes)
(:emitter
- (emit-x-form-inst segment ,op
- (fp-reg-tn-encoding frt)
+ (emit-x-form-inst segment ,op
+ (fp-reg-tn-encoding frt)
(reg-tn-encoding ra)
(reg-tn-encoding rb)
,xo
0)))))
-
+
(define-x-5-instruction (name op xo rc-p &key (cost 1) other-dependencies)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment ra rs rb)
(:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
(:delay ,cost)
(:cost ,cost)
- (:dependencies (reads rb) (reads rs) ,@other-reads
+ (:dependencies (reads rb) (reads rs) ,@other-reads
(writes ra) ,@other-writes)
(:emitter
- (emit-x-form-inst segment ,op
- (reg-tn-encoding rs)
+ (emit-x-form-inst segment ,op
+ (reg-tn-encoding rs)
(reg-tn-encoding ra)
(reg-tn-encoding rb)
,xo
(:printer x-5 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
(:delay ,cost)
(:cost ,cost)
- (:dependencies (reads ra) (reads rb) (reads rs) ,@other-reads
+ (:dependencies (reads ra) (reads rb) (reads rs) ,@other-reads
(writes :memory :partially t) ,@other-writes)
(:emitter
- (emit-x-form-inst segment ,op
- (reg-tn-encoding rs)
+ (emit-x-form-inst segment ,op
+ (reg-tn-encoding rs)
(reg-tn-encoding ra)
(reg-tn-encoding rb)
,xo
,(if rc-p 1 0))))))
-
+
(define-x-23-st-instruction (name op xo &key (cost 1) other-dependencies)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment frs ra rb)
(:printer x-23 ((op ,op) (xo ,xo)))
(:delay ,cost)
(:cost ,cost)
- (:dependencies (reads ra) (reads rb) (reads frs) ,@other-reads
+ (:dependencies (reads ra) (reads rb) (reads frs) ,@other-reads
(writes :memory :partially t) ,@other-writes)
(:emitter
- (emit-x-form-inst segment ,op
- (fp-reg-tn-encoding frs)
+ (emit-x-form-inst segment ,op
+ (fp-reg-tn-encoding frs)
(reg-tn-encoding ra)
(reg-tn-encoding rb)
,xo
(:printer x-10 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
(:delay ,cost)
(:cost ,cost)
- (:dependencies (reads rs) ,@other-reads
+ (:dependencies (reads rs) ,@other-reads
(writes ra) ,@other-writes)
(:emitter
- (emit-x-form-inst segment ,op
- (reg-tn-encoding rs)
+ (emit-x-form-inst segment ,op
+ (reg-tn-encoding rs)
(reg-tn-encoding ra)
0
,xo
(define-2-x-5-instructions (name op xo &key (cost 1) other-dependencies)
`(progn
(define-x-5-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
- (define-x-5-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
+ (define-x-5-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
:other-dependencies ,other-dependencies)))
-
+
(define-2-x-10-instructions (name op xo &key (cost 1) other-dependencies)
`(progn
(define-x-10-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
- (define-x-10-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
+ (define-x-10-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
:other-dependencies ,other-dependencies)))
-
-
+
+
(define-x-21-instruction (name op xo rc-p &key (cost 4) other-dependencies)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment frt frb)
(:printer x-21 ((op ,op) (xo ,xo) (rc ,(if rc-p 1 0))))
(:cost ,cost)
(:delay ,cost)
- (:dependencies (reads frb) ,@other-reads
+ (:dependencies (reads frb) ,@other-reads
(writes frt) ,@other-writes)
(:emitter
(emit-x-form-inst segment ,op
(fp-reg-tn-encoding frb)
,xo
,(if rc-p 1 0))))))
-
+
(define-2-x-21-instructions (name op xo &key (cost 4) other-dependencies)
`(progn
(define-x-21-instruction ,name ,op ,xo nil :cost ,cost :other-dependencies ,other-dependencies)
- (define-x-21-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
+ (define-x-21-instruction ,(symbolicate name ".") ,op ,xo t :cost ,cost
:other-dependencies ,other-dependencies)))
-
+
(define-d-si-instruction (name op &key (fixup nil) (cost 1) other-dependencies)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment rt ra si)
(:declare (type (or ,@(when fixup '(fixup))
- (unsigned-byte 16) (signed-byte 16))
- si))
+ (unsigned-byte 16) (signed-byte 16))
+ si))
(:printer d-si ((op ,op)))
(:delay ,cost)
(:cost ,cost)
- (:dependencies (reads ra) ,@other-reads
+ (:dependencies (reads ra) ,@other-reads
(writes rt) ,@other-writes)
(:emitter
(when (typep si 'fixup)
(ecase ,fixup
((:ha :l) (note-fixup segment ,fixup si)))
- (setq si 0))
+ (setq si 0))
(emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
-
+
(define-d-rs-ui-instruction (name op &key (cost 1) other-dependencies)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment ra rs ui)
(:printer d-rs-ui ((op ,op)))
(:cost ,cost)
(:delay ,cost)
- (:dependencies (reads rs) ,@other-reads
+ (:dependencies (reads rs) ,@other-reads
(writes ra) ,@other-writes)
(:emitter
(emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) ui)))))
-
+
(define-d-instruction (name op &key (cost 2) other-dependencies pinned)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment rt ra si)
(:delay ,cost)
(:cost ,cost)
,@(when pinned '(:pinned))
- (:dependencies (reads ra) (reads :memory) ,@other-reads
+ (:dependencies (reads ra) (reads :memory) ,@other-reads
(writes rt) ,@other-writes)
(:emitter
(emit-d-form-inst segment ,op (reg-tn-encoding rt) (reg-tn-encoding ra) si)))))
-
+
(define-d-frt-instruction (name op &key (cost 3) other-dependencies)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment frt ra si)
(:printer d-frt ((op ,op)))
(:delay ,cost)
(:cost ,cost)
- (:dependencies (reads ra) (reads :memory) ,@other-reads
+ (:dependencies (reads ra) (reads :memory) ,@other-reads
(writes frt) ,@other-writes)
(:emitter
(emit-d-form-inst segment ,op (fp-reg-tn-encoding frt) (reg-tn-encoding ra) si)))))
(:delay ,cost)
(:cost ,cost)
,@(when pinned '(:pinned))
- (:dependencies (reads rs) (reads ra) ,@other-reads
+ (:dependencies (reads rs) (reads ra) ,@other-reads
(writes :memory :partially t) ,@other-writes)
(:emitter
(emit-d-form-inst segment ,op (reg-tn-encoding rs) (reg-tn-encoding ra) si)))))
(:printer d-frs ((op ,op)))
(:delay ,cost)
(:cost ,cost)
- (:dependencies (reads frs) (reads ra) ,@other-reads
+ (:dependencies (reads frs) (reads ra) ,@other-reads
(writes :memory :partially t) ,@other-writes)
(:emitter
(emit-d-form-inst segment ,op (fp-reg-tn-encoding frs) (reg-tn-encoding ra) si)))))
(:delay ,cost)
(:dependencies (writes frt) (reads fra) (reads frb) (reads frc) ,@other-dependencies)
(:emitter
- (emit-a-form-inst segment
- ,op
- (fp-reg-tn-encoding frt)
- (fp-reg-tn-encoding fra)
+ (emit-a-form-inst segment
+ ,op
+ (fp-reg-tn-encoding frt)
+ (fp-reg-tn-encoding fra)
(fp-reg-tn-encoding frb)
(fp-reg-tn-encoding frb)
,xo
,rc))))
-
+
(define-2-a-instructions (name op xo &key (cost 1) other-dependencies)
`(progn
(define-a-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
(define-a-instruction ,(symbolicate name ".")
,op ,xo 1 :cost ,cost :other-dependencies ,other-dependencies)))
-
+
(define-a-tab-instruction (name op xo rc &key (cost 1) other-dependencies)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment frt fra frb)
(:dependencies (reads fra) (reads frb) ,@other-reads
(writes frt) ,@other-writes)
(:emitter
- (emit-a-form-inst segment
- ,op
- (fp-reg-tn-encoding frt)
- (fp-reg-tn-encoding fra)
+ (emit-a-form-inst segment
+ ,op
+ (fp-reg-tn-encoding frt)
+ (fp-reg-tn-encoding fra)
(fp-reg-tn-encoding frb)
0
,xo
,rc)))))
-
+
(define-2-a-tab-instructions (name op xo &key (cost 1) other-dependencies)
`(progn
(define-a-tab-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
(define-a-tab-instruction ,(symbolicate name ".")
,op ,xo 1 :cost ,cost :other-dependencies ,other-dependencies)))
-
+
(define-a-tac-instruction (name op xo rc &key (cost 1) other-dependencies)
(multiple-value-bind (other-reads other-writes) (classify-dependencies other-dependencies)
`(define-instruction ,name (segment frt fra frb)
(:dependencies (reads fra) (reads frb) ,@other-reads
(writes frt) ,@other-writes)
(:emitter
- (emit-a-form-inst segment
- ,op
- (fp-reg-tn-encoding frt)
- (fp-reg-tn-encoding fra)
+ (emit-a-form-inst segment
+ ,op
+ (fp-reg-tn-encoding frt)
+ (fp-reg-tn-encoding fra)
0
(fp-reg-tn-encoding frb)
,xo
,rc)))))
-
+
(define-2-a-tac-instructions (name op xo &key (cost 1) other-dependencies)
`(progn
(define-a-tac-instruction ,name ,op ,xo 0 :cost ,cost :other-dependencies ,other-dependencies)
(define-a-tac-instruction ,(symbolicate name ".")
,op ,xo 1 :cost ,cost :other-dependencies ,other-dependencies)))
-
+
(define-crbit-instruction (name op xo)
`(define-instruction ,name (segment dbit abit bbit)
(:printer xl ((op ,op ) (xo ,xo)))
(valid-bi-encoding bbit)
,xo
0)))))
-
+
;;; The instructions, in numerical order
(define-instruction unimp (segment data)
(:delay 0)
:pinned
(:emitter (emit-d-form-inst segment 3 (valid-tcond-encoding tcond) (reg-tn-encoding ra) si)))
-
+
(define-d-si-instruction mulli 7 :cost 5)
(define-d-si-instruction subfic 8)
-
+
(define-instruction cmplwi (segment crf ra &optional (ui nil ui-p))
(:printer d-crf-ui ((op 10) (l 0)) '(:name :tab bf "," ra "," ui))
(:dependencies (if ui-p (reads ra) (reads crf)) (writes :ccr))
(:delay 1)
- (:emitter
+ (:emitter
(unless ui-p
(setq ui ra ra crf crf :cr0))
- (emit-d-form-inst segment
+ (emit-d-form-inst segment
10
- (valid-cr-field-encoding crf)
+ (valid-cr-field-encoding crf)
(reg-tn-encoding ra)
ui)))
-
+
(define-instruction cmpwi (segment crf ra &optional (si nil si-p))
(:printer d-crf-si ((op 11) (l 0)) '(:name :tab bf "," ra "," si))
(:dependencies (if si-p (reads ra) (reads crf)) (writes :ccr))
(:delay 1)
- (:emitter
+ (:emitter
(unless si-p
(setq si ra ra crf crf :cr0))
- (emit-d-form-inst segment
+ (emit-d-form-inst segment
11
- (valid-cr-field-encoding crf)
+ (valid-cr-field-encoding crf)
(reg-tn-encoding ra)
si)))
-
+
(define-d-si-instruction addic 12 :other-dependencies ((writes :xer)))
(define-d-si-instruction addic. 13 :other-dependencies ((writes :xer) (writes :ccr)))
-
+
(define-d-si-instruction addi 14 :fixup :l)
(define-d-si-instruction addis 15 :fixup :ha)
-
+
;; There's no real support here for branch options that decrement
;; and test the CTR :
- ;; (a) the instruction scheduler doesn't know that anything's happening
+ ;; (a) the instruction scheduler doesn't know that anything's happening
;; to the CTR
- ;; (b) Lisp may have to assume that the CTR always has a lisp
+ ;; (b) Lisp may have to assume that the CTR always has a lisp
;; object/locative in it.
-
+
(define-instruction bc (segment bo bi target)
(:declare (type label target))
(:printer b ((op 16) (aa 0) (lk 0)))
(:dependencies (reads :ccr))
(:emitter
(emit-conditional-branch segment bo bi target)))
-
+
(define-instruction bcl (segment bo bi target)
(:declare (type label target))
(:printer b ((op 16) (aa 0) (lk 1)))
(:dependencies (reads :ccr))
(:emitter
(emit-conditional-branch segment bo bi target nil t)))
-
+
(define-instruction bca (segment bo bi target)
(:declare (type label target))
(:printer b ((op 16) (aa 1) (lk 0)))
(:dependencies (reads :ccr))
(:emitter
(emit-conditional-branch segment bo bi target t)))
-
+
(define-instruction bcla (segment bo bi target)
(:declare (type label target))
(:printer b ((op 16) (aa 1) (lk 1)))
(:dependencies (reads :ccr))
(:emitter
(emit-conditional-branch segment bo bi target t t)))
-
+
;;; There may (or may not) be a good reason to use this in preference
;;; to "b[la] target". I can't think of a -bad- reason ...
-
+
(define-instruction bu (segment target)
(:declare (type label target))
- (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (aa 0) (lk 0))
+ (:printer b ((op 16) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (aa 0) (lk 0))
'(:name :tab bd))
(:attributes branch)
(:delay 0)
(:emitter
(emit-conditional-branch segment #.(valid-bo-encoding :bo-u) 0 target nil nil)))
-
-
+
+
(define-instruction bt (segment bi target)
(:printer b ((op 16) (bo #.(valid-bo-encoding :bo-t)) (aa 0) (lk 0))
'(:name :tab bi "," bd))
(:delay 0)
(:emitter
(emit-conditional-branch segment #.(valid-bo-encoding :bo-t) bi target nil nil)))
-
+
(define-instruction bf (segment bi target)
(:printer b ((op 16) (bo #.(valid-bo-encoding :bo-f)) (aa 0) (lk 0))
'(:name :tab bi "," bd))
(:delay 0)
(:emitter
(emit-conditional-branch segment #.(valid-bo-encoding :bo-f) bi target nil nil)))
-
+
(define-instruction b? (segment cr-field-name cr-name &optional (target nil target-p))
(:attributes branch)
(:delay 0)
- (:emitter
+ (:emitter
(unless target-p
(setq target cr-name cr-name cr-field-name cr-field-name :cr0))
(let* ((+cond (position cr-name cr-bit-names))
(-cond (position cr-name cr-bit-inverse-names))
- (b0 (if +cond :bo-t
- (if -cond
+ (b0 (if +cond :bo-t
+ (if -cond
:bo-f
(error "Unknown branch condition ~s" cr-name))))
(cr-form (list cr-field-name (if +cond cr-name (svref cr-bit-names -cond)))))
(emit-conditional-branch segment b0 cr-form target))))
-
+
(define-instruction sc (segment)
(:printer sc ((op 17)))
(:attributes branch)
(:delay 0)
(:emitter
(emit-i-form-branch segment target nil)))
-
+
(define-instruction ba (segment target)
(:printer i-abs ((op 18) (aa 1) (lk 0)))
(:attributes branch)
(note-fixup segment :ba target)
(setq target 0))
(emit-i-form-inst segment 18 (ash target -2) 1 0)))
-
-
+
+
(define-instruction bl (segment target)
(:printer i ((op 18) (aa 0) (lk 1)))
(:attributes branch)
(:delay 0)
(:emitter
(emit-i-form-branch segment target t)))
-
+
(define-instruction bla (segment target)
(:printer i-abs ((op 18) (aa 1) (lk 1)))
(:attributes branch)
(note-fixup segment :ba target)
(setq target 0))
(emit-i-form-inst segment 18 (ash target -2) 1 1)))
-
+
(define-instruction blr (segment)
(:printer xl-bo-bi ((op 19) (xo 16) (bo #.(valid-bo-encoding :bo-u))(bi 0) (lk 0)) '(:name))
(:attributes branch)
(:dependencies (reads :ccr) (reads :ctr))
(:emitter
(emit-x-form-inst segment 19 (valid-bo-encoding :bo-u) 0 0 16 0)))
-
+
(define-instruction bclr (segment bo bi)
(:printer xl-bo-bi ((op 19) (xo 16)))
(:attributes branch)
(:dependencies (reads :ccr) (reads :lr))
(:emitter
(emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 16 0)))
-
+
(define-instruction bclrl (segment bo bi)
(:printer xl-bo-bi ((op 19) (xo 16) (lk 1)))
(:attributes branch)
(:emitter
(emit-x-form-inst segment 19 (valid-bo-encoding bo)
(valid-bi-encoding bi) 0 16 1)))
-
+
(define-crbit-instruction crnor 19 33)
(define-crbit-instruction crandc 19 129)
(define-instruction isync (segment)
(:delay 1)
:pinned
(:emitter (emit-x-form-inst segment 19 0 0 0 150 0)))
-
+
(define-crbit-instruction crxor 19 193)
(define-crbit-instruction crnand 19 225)
(define-crbit-instruction crand 19 257)
(define-crbit-instruction creqv 19 289)
(define-crbit-instruction crorc 19 417)
(define-crbit-instruction cror 19 449)
-
+
(define-instruction bcctr (segment bo bi)
(:printer xl-bo-bi ((op 19) (xo 528)))
(:attributes branch)
(:dependencies (reads :ccr) (reads :ctr))
(:emitter
(emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 0)))
-
+
(define-instruction bcctrl (segment bo bi)
(:printer xl-bo-bi ((op 19) (xo 528) (lk 1)))
(:attributes branch)
(:dependencies (reads :ccr) (reads :ctr) (writes :lr))
(:emitter
(emit-x-form-inst segment 19 (valid-bo-encoding bo) (valid-bi-encoding bi) 0 528 1)))
-
+
(define-instruction bctr (segment)
(:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 0)) '(:name))
(:attributes branch)
(:dependencies (reads :ccr) (reads :ctr))
(:emitter
(emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0 528 0)))
-
+
(define-instruction bctrl (segment)
(:printer xl-bo-bi ((op 19) (xo 528) (bo #.(valid-bo-encoding :bo-u)) (bi 0) (lk 1)) '(:name))
(:attributes branch)
(:dependencies (reads :ccr) (reads :ctr))
(:emitter
(emit-x-form-inst segment 19 #.(valid-bo-encoding :bo-u) 0 0 528 1)))
-
+
(define-instruction rlwimi (segment ra rs sh mb me)
(:printer m-sh ((op 20) (rc 0)))
(:dependencies (reads rs) (writes ra))
(:delay 1)
(:emitter
(emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
-
+
(define-instruction rlwimi. (segment ra rs sh mb me)
(:printer m-sh ((op 20) (rc 1)))
(:dependencies (reads rs) (writes ra) (writes :ccr))
(:delay 1)
(:emitter
(emit-a-form-inst segment 20 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 1)))
-
+
(define-instruction rlwinm (segment ra rs sh mb me)
(:printer m-sh ((op 21) (rc 0)))
(:delay 1)
(:dependencies (reads rs) (writes ra))
(:emitter
(emit-a-form-inst segment 21 (reg-tn-encoding rs) (reg-tn-encoding ra) sh mb me 0)))
-
+
(define-instruction rlwinm. (segment ra rs sh mb me)
(:printer m-sh ((op 21) (rc 1)))
(:delay 1)
(:dependencies (reads rs) (writes ra) (reads rb))
(:emitter
(emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 0)))
-
+
(define-instruction rlwnm. (segment ra rs rb mb me)
(:printer m ((op 23) (rc 1) (rb nil :type 'reg)))
(:delay 1)
(:dependencies (reads rs) (reads rb) (writes ra) (writes :ccr))
(:emitter
(emit-a-form-inst segment 23 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) mb me 1)))
-
-
+
+
(define-d-rs-ui-instruction ori 24)
-
+
(define-instruction nop (segment)
(:printer d-rs-ui ((op 24) (rs 0) (ra 0) (ui 0)) '(:name))
(:cost 1)
(:delay 1)
(:emitter
(emit-d-form-inst segment 24 0 0 0)))
-
+
(define-d-rs-ui-instruction oris 25)
(define-d-rs-ui-instruction xori 26)
(define-d-rs-ui-instruction xoris 27)
(define-d-rs-ui-instruction andi. 28 :other-dependencies ((writes :ccr)))
(define-d-rs-ui-instruction andis. 29 :other-dependencies ((writes :ccr)))
-
+
(define-instruction cmpw (segment crf ra &optional (rb nil rb-p))
(:printer x-14 ((op 31) (xo 0) (l 0)) '(:name :tab bf "," ra "," rb))
(:delay 1)
(:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
- (:emitter
+ (:emitter
(unless rb-p
(setq rb ra ra crf crf :cr0))
- (emit-x-form-inst segment
+ (emit-x-form-inst segment
31
- (valid-cr-field-encoding crf)
+ (valid-cr-field-encoding crf)
(reg-tn-encoding ra)
(reg-tn-encoding rb)
0
0)))
-
+
(define-instruction tw (segment tcond ra rb)
(:printer x-19 ((op 31) (xo 4)))
(:attributes branch)
(:delay 0)
:pinned
(:emitter (emit-x-form-inst segment 31 (valid-tcond-encoding tcond) (reg-tn-encoding ra) (reg-tn-encoding rb) 4 0)))
-
+
(define-4-xo-instructions subfc 31 8 :always-writes-xer t)
(define-4-xo-instructions addc 31 10 :always-writes-xer t)
(define-2-xo-oe-instructions mulhwu 31 11 :cost 5)
-
+
(define-instruction mfcr (segment rd)
(:printer x-4 ((op 31) (xo 19)))
(:delay 1)
(:dependencies (reads :ccr) (writes rd))
(:emitter (emit-x-form-inst segment 31 (reg-tn-encoding rd) 0 0 19 0)))
-
+
(define-x-instruction lwarx 31 20)
(define-x-instruction lwzx 31 23)
(define-2-x-5-instructions slw 31 24)
(define-2-x-10-instructions cntlzw 31 26)
(define-2-x-5-instructions and 31 28)
-
+
(define-instruction cmplw (segment crf ra &optional (rb nil rb-p))
(:printer x-14 ((op 31) (xo 32) (l 0)) '(:name :tab bf "," ra "," rb))
(:delay 1)
(:dependencies (reads ra) (if rb-p (reads rb) (reads crf)) (reads :xer) (writes :ccr))
- (:emitter
+ (:emitter
(unless rb-p
(setq rb ra ra crf crf :cr0))
- (emit-x-form-inst segment
+ (emit-x-form-inst segment
31
- (valid-cr-field-encoding crf)
+ (valid-cr-field-encoding crf)
(reg-tn-encoding ra)
(reg-tn-encoding rb)
32
0)))
-
-
+
+
(define-4-xo-instructions subf 31 40)
; dcbst
(define-x-instruction lwzux 31 55 :other-dependencies ((writes rt)))
(define-2-x-5-instructions andc 31 60)
(define-2-xo-oe-instructions mulhw 31 75 :cost 5)
-
+
(define-x-instruction lbzx 31 87)
(define-4-xo-a-instructions neg 31 104)
(define-x-instruction lbzux 31 119 :other-dependencies ((writes rt)))
(define-2-x-5-instructions nor 31 124)
(define-4-xo-instructions subfe 31 136 :always-reads-xer t :always-writes-xer t)
-
+
(define-instruction-macro sube (rt ra rb)
`(inst subfe ,rt ,rb ,ra))
-
+
(define-instruction-macro sube. (rt ra rb)
`(inst subfe. ,rt ,rb ,ra))
-
+
(define-instruction-macro subeo (rt ra rb)
`(inst subfeo ,rt ,rb ,ra))
-
+
(define-instruction-macro subeo. (rt ra rb)
`(inst subfeo ,rt ,rb ,ra))
-
+
(define-4-xo-instructions adde 31 138 :always-reads-xer t :always-writes-xer t)
-
+
(define-instruction mtcrf (segment mask rt)
(:printer xfx-fxm ((op 31) (xo 144)))
(:delay 1)
(:dependencies (reads rt) (writes :ccr))
(:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash mask 1) 144 0)))
-
+
(define-x-5-st-instruction stwcx. 31 150 t :other-dependencies ((writes :ccr)))
(define-x-5-st-instruction stwx 31 151 nil)
(define-x-5-st-instruction stwux 31 183 nil :other-dependencies ((writes ra)))
(define-2-x-5-instructions eqv 31 284)
(define-x-instruction lhzux 31 311 :other-dependencies ((writes ra)))
(define-2-x-5-instructions xor 31 316)
-
+
(define-instruction mfmq (segment rt)
(:printer xfx ((op 31) (xo 339) (spr 0)) '(:name :tab rt))
(:delay 1)
(:dependencies (reads :xer) (writes rt))
(:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 339 0)))
-
+
(define-instruction mfxer (segment rt)
(:printer xfx ((op 31) (xo 339) (spr 1)) '(:name :tab rt))
(:delay 1)
(:dependencies (reads :xer) (writes rt))
(:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 339 0)))
-
+
(define-instruction mflr (segment rt)
(:printer xfx ((op 31) (xo 339) (spr 8)) '(:name :tab rt))
(:delay 1)
(:dependencies (reads :lr) (writes rt))
(:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 339 0)))
-
+
(define-instruction mfctr (segment rt)
(:printer xfx ((op 31) (xo 339) (spr 9)) '(:name :tab rt))
(:delay 1)
(:dependencies (reads rt) (reads :ctr))
(:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 339 0)))
-
-
+
+
(define-x-instruction lhax 31 343)
(define-x-instruction lhaux 31 375 :other-dependencies ((writes ra)))
(define-x-5-st-instruction sthx 31 407 nil)
(define-2-x-5-instructions orc 31 412)
(define-x-5-st-instruction sthux 31 439 nil :other-dependencies ((writes ra)))
-
+
(define-instruction or (segment ra rs rb)
(:printer x-5 ((op 31) (xo 444) (rc 0)) '((:cond
((rs :same-as rb) 'mr)
(:emitter
(emit-x-form-inst segment
31
- (reg-tn-encoding rs)
+ (reg-tn-encoding rs)
(reg-tn-encoding ra)
(reg-tn-encoding rb)
444
0)))
-
+
(define-instruction or. (segment ra rs rb)
(:printer x-5 ((op 31) (xo 444) (rc 1)) '((:cond
((rs :same-as rb) 'mr.)
(:emitter
(emit-x-form-inst segment
31
- (reg-tn-encoding rs)
+ (reg-tn-encoding rs)
(reg-tn-encoding ra)
(reg-tn-encoding rb)
444
1)))
-
+
(define-instruction-macro mr (ra rs)
`(inst or ,ra ,rs ,rs))
-
+
(define-instruction-macro mr. (ra rs)
`(inst or. ,ra ,rs ,rs))
-
+
(define-4-xo-instructions divwu 31 459 :cost 36)
-
+
; This is a 601-specific instruction class.
(define-4-xo-instructions div 31 331 :cost 36)
-
+
; This is a 601-specific instruction.
(define-instruction mtmq (segment rt)
(:printer xfx ((op 31) (xo 467) (spr (ash 0 5))) '(:name :tab rt))
(:delay 1)
(:dependencies (reads rt) (writes :xer))
(:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 0 5) 467 0)))
-
+
(define-instruction mtxer (segment rt)
(:printer xfx ((op 31) (xo 467) (spr (ash 1 5))) '(:name :tab rt))
(:delay 1)
(:dependencies (reads rt) (writes :xer))
(:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 1 5) 467 0)))
-
+
(define-instruction mtlr (segment rt)
(:printer xfx ((op 31) (xo 467) (spr (ash 8 5))) '(:name :tab rt))
(:delay 1)
(:dependencies (reads rt) (writes :lr))
(:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 8 5) 467 0)))
-
+
(define-instruction mtctr (segment rt)
(:printer xfx ((op 31) (xo 467) (spr (ash 9 5))) '(:name :tab rt))
(:delay 1)
(:dependencies (reads rt) (writes :ctr))
(:emitter (emit-xfx-form-inst segment 31 (reg-tn-encoding rt) (ash 9 5) 467 0)))
-
-
+
+
(define-2-x-5-instructions nand 31 476)
(define-4-xo-instructions divw 31 491 :cost 36)
(define-instruction mcrxr (segment crf)
(:delay 1)
(:dependencies (reads :xer) (writes :ccr) (writes :xer))
(:emitter (emit-x-form-inst segment 31 (valid-cr-field-encoding crf) 0 0 512 0)))
-
- (define-instruction lswx (segment rs ra rb)
+
+ (define-instruction lswx (segment rs ra rb)
(:printer x ((op 31) (xo 533) (rc 0)))
(:delay 1)
:pinned
- (:cost 8)
+ (:cost 8)
(:emitter (emit-x-form-inst sb!assem:segment 31 (reg-tn-encoding rs) (reg-tn-encoding ra) (reg-tn-encoding rb) 533 0)))
(define-x-instruction lwbrx 31 534)
(define-x-20-instruction lfsx 31 535)
(define-2-x-5-instructions srw 31 536)
(define-x-20-instruction lfsux 31 567 :other-dependencies ((writes ra)))
-
- (define-instruction lswi (segment rt ra rb)
+
+ (define-instruction lswi (segment rt ra rb)
(:printer x-1 ((op 31) (xo 597) (rc 0)))
:pinned
(:delay 8)
- (:cost 8)
+ (:cost 8)
(:emitter (emit-x-form-inst sb!assem:segment 31 (reg-tn-encoding rt) (reg-tn-encoding ra) rb 597 0)))
-
+
(define-instruction sync (segment)
(:printer x-27 ((op 31) (xo 598)))
(:delay 1)
(:emitter (emit-x-form-inst segment 31 0 0 0 598 0)))
(define-x-20-instruction lfdx 31 599)
(define-x-20-instruction lfdux 31 631 :other-dependencies ((writes ra)))
- (define-instruction stswx (segment rs ra rb)
+ (define-instruction stswx (segment rs ra rb)
(:printer x-5 ((op 31) (xo 661)))
:pinned
- (:cost 8)
+ (:cost 8)
(:delay 1)
- (:emitter (emit-x-form-inst sb!assem:segment 31
- (reg-tn-encoding rs)
- (reg-tn-encoding ra)
- (reg-tn-encoding rb)
- 661
+ (:emitter (emit-x-form-inst sb!assem:segment 31
+ (reg-tn-encoding rs)
+ (reg-tn-encoding ra)
+ (reg-tn-encoding rb)
+ 661
0)))
(define-x-5-st-instruction stwbrx 31 662 nil)
(define-x-23-st-instruction stfsx 31 663)
(:delay 1)
(:emitter
(emit-x-form-inst segment 31
- (reg-tn-encoding rs)
+ (reg-tn-encoding rs)
(reg-tn-encoding ra)
nb
725
0)))
-
+
(define-x-23-st-instruction stfdx 31 727)
(define-x-23-st-instruction stfdux 31 759 :other-dependencies ((writes ra)))
(define-x-instruction lhbrx 31 790)
(define-2-x-5-instructions sraw 31 792)
-
+
(define-instruction srawi (segment ra rs rb)
(:printer x-9 ((op 31) (xo 824) (rc 0)))
(:cost 1)
(:dependencies (reads rs) (writes ra))
(:emitter
(emit-x-form-inst segment 31
- (reg-tn-encoding rs)
+ (reg-tn-encoding rs)
(reg-tn-encoding ra)
rb
824
0)))
-
+
(define-instruction srawi. (segment ra rs rb)
(:printer x-9 ((op 31) (xo 824) (rc 1)))
(:cost 1)
(:dependencies (reads rs) (writes ra) (writes :ccr))
(:emitter
(emit-x-form-inst segment 31
- (reg-tn-encoding rs)
+ (reg-tn-encoding rs)
(reg-tn-encoding ra)
rb
824
1)))
-
+
(define-instruction eieio (segment)
(:printer x-27 ((op 31) (xo 854)))
:pinned
(:delay 1)
(:emitter (emit-x-form-inst segment 31 0 0 0 854 0)))
-
+
(define-x-5-st-instruction sthbrx 31 918 nil)
-
+
(define-2-x-10-instructions extsb 31 954)
(define-2-x-10-instructions extsh 31 922)
; Whew.
-
+
(define-instruction lwz (segment rt ra si)
(:declare (type (or fixup (signed-byte 16)) si))
(:printer d ((op 32)))
(note-fixup segment :l si)
(setq si 0))
(emit-d-form-inst segment 32 (reg-tn-encoding rt) (reg-tn-encoding ra) si)))
-
+
(define-d-instruction lwzu 33 :other-dependencies ((writes ra)))
(define-d-instruction lbz 34)
(define-d-instruction lbzu 35 :other-dependencies ((writes ra)))
(define-d-frs-instruction stfsu 53 :other-dependencies ((writes ra)))
(define-d-frs-instruction stfd 54)
(define-d-frs-instruction stfdu 55 :other-dependencies ((writes ra)))
-
+
(define-2-a-tab-instructions fdivs 59 18 :cost 17)
(define-2-a-tab-instructions fsubs 59 20)
(define-2-a-tab-instructions fadds 59 21)
(define-instruction fcmpu (segment crfd fra frb)
(:printer x-15 ((op 63) (xo 0)))
- (:dependencies (reads fra) (reads frb) (reads :fpscr)
+ (:dependencies (reads fra) (reads frb) (reads :fpscr)
(writes :fpscr) (writes :ccr))
(:cost 4)
(:delay 4)
- (:emitter (emit-x-form-inst segment
- 63
+ (:emitter (emit-x-form-inst segment
+ 63
(valid-cr-field-encoding crfd)
- (fp-reg-tn-encoding fra)
+ (fp-reg-tn-encoding fra)
(fp-reg-tn-encoding frb)
0
0)))
-
-
+
+
(define-2-x-21-instructions frsp 63 12)
(define-2-x-21-instructions fctiw 63 14)
(define-2-x-21-instructions fctiwz 63 15)
-
+
(define-2-a-tab-instructions fdiv 63 18 :cost 31)
(define-2-a-tab-instructions fsub 63 20)
(define-2-a-tab-instructions fadd 63 21)
(define-2-a-instructions fmadd 63 29 :cost 5)
(define-2-a-instructions fnmsub 63 30 :cost 5)
(define-2-a-instructions fnmadd 63 31 :cost 5)
-
+
(define-instruction fcmpo (segment crfd fra frb)
(:printer x-15 ((op 63) (xo 32)))
- (:dependencies (reads fra) (reads frb) (reads :fpscr)
+ (:dependencies (reads fra) (reads frb) (reads :fpscr)
(writes :fpscr) (writes :ccr))
(:cost 4)
(:delay 1)
- (:emitter (emit-x-form-inst segment
- 63
+ (:emitter (emit-x-form-inst segment
+ 63
(valid-cr-field-encoding crfd)
- (fp-reg-tn-encoding fra)
+ (fp-reg-tn-encoding fra)
(fp-reg-tn-encoding frb)
32
0)))
-
+
(define-2-x-21-instructions fneg 63 40)
-
+
(define-2-x-21-instructions fmr 63 72)
(define-2-x-21-instructions fnabs 63 136)
(define-2-x-21-instructions fabs 63 264)
-
+
(define-instruction mffs (segment frd)
(:printer x-22 ((op 63) (xo 583) (rc 0)))
(:delay 1)
(:dependencies (reads :fpscr) (writes frd))
- (:emitter (emit-x-form-inst segment
- 63
+ (:emitter (emit-x-form-inst segment
+ 63
(fp-reg-tn-encoding frd)
- 0
+ 0
0
583
0)))
(:printer x-22 ((op 63) (xo 583) (rc 1)))
(:delay 1)
(:dependencies (reads :fpscr) (writes frd) (writes :ccr))
- (:emitter (emit-x-form-inst segment
- 63
+ (:emitter (emit-x-form-inst segment
+ 63
(fp-reg-tn-encoding frd)
- 0
+ 0
0
583
1)))
(define-instruction-macro subis (rt ra simm)
`(inst addis ,rt ,ra (- ,simm)))
-
+
(define-instruction-macro sub (rt rb ra)
`(inst subf ,rt ,ra ,rb))
(define-instruction-macro sub. (rt rb ra)
(define-instruction-macro subic (rt ra simm)
`(inst addic ,rt ,ra (- ,simm)))
-
+
(define-instruction-macro subic. (rt ra simm)
`(inst addic. ,rt ,ra (- ,simm)))
-
-
-
+
+
+
(define-instruction-macro subc (rt rb ra)
`(inst subfc ,rt ,ra ,rb))
(define-instruction-macro subc. (rt rb ra)
`(inst subfco ,rt ,ra ,rb))
(define-instruction-macro subco. (rt rb ra)
`(inst subfco. ,rt ,ra ,rb))
-
+
(define-instruction-macro subi (rt ra simm)
`(inst addi ,rt ,ra (- ,simm)))
-
+
(define-instruction-macro li (rt val)
`(inst addi ,rt zero-tn ,val))
-
+
(define-instruction-macro lis (rt val)
`(inst addis ,rt zero-tn ,val))
-
-
+
+
(define-instruction-macro not (ra rs)
`(inst nor ,ra ,rs ,rs))
-
+
(define-instruction-macro not. (ra rs)
`(inst nor. ,ra ,rs ,rs))
-
-
+
+
(!def-vm-support-routine emit-nop (segment)
(emit-word segment #x60000000))
-
+
(define-instruction-macro extlwi (ra rs n b)
`(inst rlwinm ,ra ,rs ,b 0 (1- ,n)))
-
+
(define-instruction-macro extlwi. (ra rs n b)
`(inst rlwinm. ,ra ,rs ,b 0 (1- ,n)))
-
+
(define-instruction-macro srwi (ra rs n)
`(inst rlwinm ,ra ,rs (- 32 ,n) ,n 31))
-
+
(define-instruction-macro srwi. (ra rs n)
`(inst rlwinm. ,ra ,rs (- 32 ,n) ,n 31))
-
+
(define-instruction-macro clrrwi (ra rs n)
`(inst rlwinm ,ra ,rs 0 0 (- 31 ,n)))
-
+
(define-instruction-macro clrrwi. (ra rs n)
`(inst rlwinm. ,ra ,rs 0 0 (- 31 ,n)))
-
+
(define-instruction-macro inslw (ra rs n b)
`(inst rlwimi ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
-
+
(define-instruction-macro inslw. (ra rs n b)
`(inst rlwimi. ,ra ,rs (- 32 ,b) ,b (+ ,b (1- ,n))))
-
+
(define-instruction-macro rotlw (ra rs rb)
`(inst rlwnm ,ra ,rs ,rb 0 31))
-
+
(define-instruction-macro rotlw. (ra rs rb)
`(inst rlwnm. ,ra ,rs ,rb 0 31))
-
+
(define-instruction-macro rotlwi (ra rs n)
`(inst rlwinm ,ra ,rs ,n 0 31))
(define-instruction-macro slwi. (ra rs n)
`(inst rlwinm. ,ra ,rs ,n 0 (- 31 ,n))))
-
+
#|
-(macrolet
+(macrolet
((define-conditional-branches (name bo-name)
(let* ((bo-enc (valid-bo-encoding bo-name)))
`(progn
(define-conditional-branches bf :bo-f))
|#
-(macrolet
+(macrolet
((define-positive-conditional-branches (name cr-bit-name)
`(progn
(define-instruction-macro ,name (crf &optional (target nil target-p))
(define-positive-conditional-branches bun :so))
-(macrolet
+(macrolet
((define-negative-conditional-branches (name cr-bit-name)
`(progn
(define-instruction-macro ,name (crf &optional (target nil target-p))
`(inst bclrl :bo-u 0))
\f
-;;; Some more macros
+;;; Some more macros
(defun %lr (reg value)
(etypecase value
(low-half (ldb (byte 16 0) value)))
(declare (type (unsigned-byte 16) high-half low-half))
(cond ((and (logbitp 15 low-half) (= high-half #xffff))
- (inst li reg (dpb low-half (byte 16 0) -1)))
- ((and (not (logbitp 15 low-half)) (zerop high-half))
- (inst li reg low-half))
+ (inst li reg (dpb low-half (byte 16 0) -1)))
+ ((and (not (logbitp 15 low-half)) (zerop high-half))
+ (inst li reg low-half))
(t
- (inst lis reg (if (logbitp 15 high-half)
- (dpb high-half (byte 16 0) -1)
- high-half))
+ (inst lis reg (if (logbitp 15 high-half)
+ (dpb high-half (byte 16 0) -1)
+ high-half))
(unless (zerop low-half)
(inst ori reg reg low-half))))))
(fixup
(define-instruction-macro lr (reg value)
`(%lr ,reg ,value))
-
+
\f
;;;; Instructions for dumping data and header objects.
segment 4
#'(lambda (segment posn)
(emit-word segment
- (logior type
- (ash (+ posn (component-header-length))
- (- n-widetag-bits word-shift)))))))
+ (logior type
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift)))))))
(define-instruction simple-fun-header-word (segment)
:pinned
segment 12 3
#'(lambda (segment posn delta-if-after)
(let ((delta (funcall calc label posn delta-if-after)))
- (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
- (emit-back-patch segment 4
- #'(lambda (segment posn)
- (assemble (segment vop)
- (inst addi dst src
- (funcall calc label posn 0)))))
- t)))
+ (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (assemble (segment vop)
+ (inst addi dst src
+ (funcall calc label posn 0)))))
+ t)))
#'(lambda (segment posn)
(let ((delta (funcall calc label posn 0)))
- (assemble (segment vop)
- (inst lis temp (ldb (byte 16 16) delta))
- (inst ori temp temp (ldb (byte 16 0) delta))
- (inst add dst src temp))))))
+ (assemble (segment vop)
+ (inst lis temp (ldb (byte 16 16) delta))
+ (inst ori temp temp (ldb (byte 16 0) delta))
+ (inst add dst src temp))))))
;; this function is misnamed. should be compute-code-from-lip,
;; if the use in xep-allocate-frame is typical
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (- other-pointer-lowtag
- ;;function-pointer-type
- (label-position label posn delta-if-after)
- (component-header-length))))))
+ #'(lambda (label posn delta-if-after)
+ (- other-pointer-lowtag
+ ;;function-pointer-type
+ (label-position label posn delta-if-after)
+ (component-header-length))))))
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-lra (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (- (+ (label-position label posn delta-if-after)
- (component-header-length)))))))
+ #'(lambda (label posn delta-if-after)
+ (- (+ (label-position label posn delta-if-after)
+ (component-header-length)))))))
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
(define-instruction compute-lra-from-code (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- #'(lambda (label posn delta-if-after)
- (+ (label-position label posn delta-if-after)
- (component-header-length))))))
+ #'(lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length))))))
(defmacro move (dst src)
"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 mr ,n-dst ,n-src))))
(macrolet
((def (op inst shift)
`(defmacro ,op (object base &optional (offset 0) (lowtag 0))
- `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
+ `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
(def loadw lwz word-shift)
(def storew stw word-shift))
(macrolet
((frob (slot)
(let ((loader (intern (concatenate 'simple-string
- "LOAD-SYMBOL-"
- (string slot))))
- (storer (intern (concatenate 'simple-string
- "STORE-SYMBOL-"
- (string slot))))
- (offset (intern (concatenate 'simple-string
- "SYMBOL-"
- (string slot)
- "-SLOT")
- (find-package "SB!VM"))))
- `(progn
- (defmacro ,loader (reg symbol)
- `(inst lwz ,reg null-tn
- (+ (static-symbol-offset ',symbol)
- (ash ,',offset word-shift)
- (- other-pointer-lowtag))))
- (defmacro ,storer (reg symbol)
- `(inst stw ,reg null-tn
- (+ (static-symbol-offset ',symbol)
- (ash ,',offset word-shift)
- (- other-pointer-lowtag))))))))
+ "LOAD-SYMBOL-"
+ (string slot))))
+ (storer (intern (concatenate 'simple-string
+ "STORE-SYMBOL-"
+ (string slot))))
+ (offset (intern (concatenate 'simple-string
+ "SYMBOL-"
+ (string slot)
+ "-SLOT")
+ (find-package "SB!VM"))))
+ `(progn
+ (defmacro ,loader (reg symbol)
+ `(inst lwz ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash ,',offset word-shift)
+ (- other-pointer-lowtag))))
+ (defmacro ,storer (reg symbol)
+ `(inst stw ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash ,',offset word-shift)
+ (- other-pointer-lowtag))))))))
(frob value)
(frob function))
"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 lbz ,n-target ,n-source ,n-offset))
`(inst lbz ,n-target ,n-source (+ ,n-offset 3))))))
;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions.
+;;; return instructions.
(defmacro lisp-jump (function lip)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
;;; Move a stack TN to a register and vice-versa.
(defmacro load-stack-tn (reg stack)
`(let ((reg ,reg)
- (stack ,stack))
+ (stack ,stack))
(let ((offset (tn-offset stack)))
(sc-case stack
- ((control-stack)
- (loadw reg cfp-tn offset))))))
+ ((control-stack)
+ (loadw reg cfp-tn offset))))))
(defmacro store-stack-tn (stack reg)
`(let ((stack ,stack)
- (reg ,reg))
+ (reg ,reg))
(let ((offset (tn-offset stack)))
(sc-case stack
- ((control-stack)
- (storew reg cfp-tn offset))))))
+ ((control-stack)
+ (storew reg cfp-tn offset))))))
(defmacro maybe-load-stack-tn (reg reg-or-stack)
"Move the TN Reg-Or-Stack into Reg if it isn't already there."
(once-only ((n-reg reg)
- (n-stack reg-or-stack))
+ (n-stack reg-or-stack))
`(sc-case ,n-reg
((any-reg descriptor-reg)
- (sc-case ,n-stack
- ((any-reg descriptor-reg)
- (move ,n-reg ,n-stack))
- ((control-stack)
- (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+ (sc-case ,n-stack
+ ((any-reg descriptor-reg)
+ (move ,n-reg ,n-stack))
+ ((control-stack)
+ (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
\f
;;;; Storage allocation:
(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
- &body body)
+ &body body)
"Do stuff to allocate an other-pointer object of fixed Size with a single
word header having the specified Type-Code. The result is placed in
Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
(unless body
(bug "empty &body in WITH-FIXED-ALLOCATION"))
(once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
- (type-code type-code) (size size))
+ (type-code type-code) (size size))
`(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
(inst ori ,result-tn alloc-tn other-pointer-lowtag)
(inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
`((let ((vop ,vop))
- (when vop
- (note-this-location vop :internal-error)))
- (inst unimp ,kind)
- (with-adjustable-vector (,vector)
- (write-var-integer (error-number-or-lose ',code) ,vector)
- ,@(mapcar #'(lambda (tn)
- `(let ((tn ,tn))
- (write-var-integer (make-sc-offset (sc-number
- (tn-sc tn))
- (tn-offset tn))
- ,vector)))
- values)
- (inst byte (length ,vector))
- (dotimes (i (length ,vector))
- (inst byte (aref ,vector i))))
- (align word-shift)))))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst unimp ,kind)
+ (with-adjustable-vector (,vector)
+ (write-var-integer (error-number-or-lose ',code) ,vector)
+ ,@(mapcar #'(lambda (tn)
+ `(let ((tn ,tn))
+ (write-var-integer (make-sc-offset (sc-number
+ (tn-sc tn))
+ (tn-offset tn))
+ ,vector)))
+ values)
+ (inst byte (length ,vector))
+ (dotimes (i (length ,vector))
+ (inst byte (aref ,vector i))))
+ (align word-shift)))))
(defmacro error-call (vop error-code &rest values)
"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 cerror-call (vop label error-code &rest values)
`(let ((,continue (gen-label)))
(emit-label ,continue)
(assemble (*elsewhere*)
- (let ((,error (gen-label)))
- (emit-label ,error)
- (cerror-call ,vop ,continue ,error-code ,@values)
- ,error)))))
+ (let ((,error (gen-label)))
+ (emit-label ,error)
+ (cerror-call ,vop ,continue ,error-code ,@values)
+ ,error)))))
\f
;;;; PSEUDO-ATOMIC
(let ((n-extra (gensym)))
`(let ((,n-extra ,extra))
(without-scheduling ()
- ;; Extra debugging stuff:
- #+debug
- (progn
- (inst andi. ,flag-tn alloc-tn 7)
- (inst twi :ne ,flag-tn 0))
- (inst lr ,flag-tn (- ,n-extra 4))
- (inst addi alloc-tn alloc-tn 4))
+ ;; Extra debugging stuff:
+ #+debug
+ (progn
+ (inst andi. ,flag-tn alloc-tn 7)
+ (inst twi :ne ,flag-tn 0))
+ (inst lr ,flag-tn (- ,n-extra 4))
+ (inst addi alloc-tn alloc-tn 4))
,@forms
(without-scheduling ()
(inst add alloc-tn alloc-tn ,flag-tn)
(inst twi :lt alloc-tn 0))
#+debug
(progn
- (inst andi. ,flag-tn alloc-tn 7)
- (inst twi :ne ,flag-tn 0)))))
+ (inst andi. ,flag-tn alloc-tn 7)
+ (inst twi :ne ,flag-tn 0)))))
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
garbage collection. This is currently implemented by disabling GC"
- (declare (ignore objects)) ;should we eval these for side-effect?
+ (declare (ignore objects)) ;should we eval these for side-effect?
`(without-gcing
,@body))
;;;
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
+ (value :scs (descriptor-reg any-reg)))
(:variant-vars base lowtag)
(:info offset)
(:generator 4
(defmacro define-indexer (name write-p ri-op rr-op shift &optional sign-extend-byte)
`(define-vop (,name)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- ,@(when write-p
- '((value :scs (any-reg descriptor-reg) :target result))))
+ (index :scs (any-reg zero immediate))
+ ,@(when write-p
+ '((value :scs (any-reg descriptor-reg) :target result))))
(:arg-types * tagged-num ,@(when write-p '(*)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (,(if write-p 'result 'value)
- :scs (any-reg descriptor-reg)))
+ :scs (any-reg descriptor-reg)))
(:result-types *)
(:variant-vars offset lowtag)
(:policy :fast-safe)
(:generator 5
(sc-case index
- ((immediate zero)
- (let ((offset (- (+ (if (sc-is index zero)
- 0
- (ash (tn-value index)
- (- word-shift ,shift)))
- (ash offset word-shift))
- lowtag)))
- (etypecase offset
- ((signed-byte 16)
- (inst ,ri-op value object offset))
- ((or (unsigned-byte 32) (signed-byte 32))
- (inst lr temp offset)
- (inst ,rr-op value object temp)))))
- (t
- ,@(unless (zerop shift)
- `((inst srwi temp index ,shift)))
- (inst addi temp ,(if (zerop shift) 'index 'temp)
- (- (ash offset word-shift) lowtag))
- (inst ,rr-op value object temp)))
+ ((immediate zero)
+ (let ((offset (- (+ (if (sc-is index zero)
+ 0
+ (ash (tn-value index)
+ (- word-shift ,shift)))
+ (ash offset word-shift))
+ lowtag)))
+ (etypecase offset
+ ((signed-byte 16)
+ (inst ,ri-op value object offset))
+ ((or (unsigned-byte 32) (signed-byte 32))
+ (inst lr temp offset)
+ (inst ,rr-op value object temp)))))
+ (t
+ ,@(unless (zerop shift)
+ `((inst srwi temp index ,shift)))
+ (inst addi temp ,(if (zerop shift) 'index 'temp)
+ (- (ash offset word-shift) lowtag))
+ (inst ,rr-op value object temp)))
,@(when sign-extend-byte
`((inst extsb value value)))
,@(when write-p
- '((move result value))))))
+ '((move result value))))))
(define-indexer word-index-ref nil lwz lwzx 0)
(define-indexer word-index-set t stw stwx 0)
(load-symbol y val))
(character
(inst lr y (logior (ash (char-code val) n-widetag-bits)
- character-widetag))))))
+ character-widetag))))))
(define-move-fun (load-number 1) (vop x y)
((immediate zero)
;;;; The Move VOP:
(define-vop (move)
(:args (x :target y
- :scs (any-reg descriptor-reg zero null)
- :load-if (not (location= x y))))
+ :scs (any-reg descriptor-reg zero null)
+ :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))))
(:effects)
(:affected)
(:generator 0
;;; frame for argument or known value passing.
(define-vop (move-arg)
(:args (x :target y
- :scs (any-reg descriptor-reg zero null))
- (fp :scs (any-reg)
- :load-if (not (sc-is y any-reg descriptor-reg))))
+ :scs (any-reg descriptor-reg zero null))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y any-reg descriptor-reg))))
(:results (y))
(:generator 0
(sc-case y
(let ((done (gen-label)))
(inst andi. temp x 3)
(sc-case y
- (signed-reg
- (inst srawi y x 2))
- (unsigned-reg
- (inst srwi y x 2)))
-
+ (signed-reg
+ (inst srawi y x 2))
+ (unsigned-reg
+ (inst srwi y x 2)))
+
(inst beq done)
(loadw y x bignum-digits-offset other-pointer-lowtag)
-
+
(emit-label done))))
(define-move-vop move-to-word/integer :move
(descriptor-reg) (signed-reg unsigned-reg))
(inst addo. temp temp temp) ; set CR0 SO if any top three bits differ
(inst slwi y x 2) ; assume fixnum (tagged ok, maybe lost some high bits)
(inst bns done)
-
+
(with-fixed-allocation (y pa-flag temp bignum-widetag (1+ bignum-digits-offset))
- (storew x y bignum-digits-offset other-pointer-lowtag))
+ (storew x y bignum-digits-offset other-pointer-lowtag))
(emit-label done))))
(define-move-vop move-from-signed :move
(signed-reg) (descriptor-reg))
(:generator 20
(move x arg)
(let ((done (gen-label))
- (one-word (gen-label))
- (initial-alloc (pad-data-block (1+ bignum-digits-offset))))
+ (one-word (gen-label))
+ (initial-alloc (pad-data-block (1+ bignum-digits-offset))))
(inst srawi. temp x 29)
(inst slwi y x 2)
(inst beq done)
-
+
(pseudo-atomic (pa-flag :extra initial-alloc)
- (inst cmpwi x 0)
- (inst ori y alloc-tn other-pointer-lowtag)
- (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
- (inst bge one-word)
- (inst addi alloc-tn alloc-tn
- (- (pad-data-block (+ bignum-digits-offset 2))
- (pad-data-block (+ bignum-digits-offset 1))))
- (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
- (emit-label one-word)
- (storew temp y 0 other-pointer-lowtag)
- (storew x y bignum-digits-offset other-pointer-lowtag))
+ (inst cmpwi x 0)
+ (inst ori y alloc-tn other-pointer-lowtag)
+ (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
+ (inst bge one-word)
+ (inst addi alloc-tn alloc-tn
+ (- (pad-data-block (+ bignum-digits-offset 2))
+ (pad-data-block (+ bignum-digits-offset 1))))
+ (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+ (emit-label one-word)
+ (storew temp y 0 other-pointer-lowtag)
+ (storew x y bignum-digits-offset other-pointer-lowtag))
(emit-label done))))
(define-move-vop move-from-unsigned :move
(unsigned-reg) (descriptor-reg))
;;; Move untagged numbers.
(define-vop (word-move)
(:args (x :target y
- :scs (signed-reg unsigned-reg)
- :load-if (not (location= x y))))
+ :scs (signed-reg unsigned-reg)
+ :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))))
(:effects)
(:affected)
(:note "word integer move")
;;; Move untagged number arguments/return-values.
(define-vop (move-word-arg)
(:args (x :target y
- :scs (signed-reg unsigned-reg))
- (fp :scs (any-reg)
- :load-if (not (sc-is y sap-reg))))
+ :scs (signed-reg unsigned-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "word integer argument move")
(:generator 0
(define-vop (save-dynamic-state)
(:results (catch :scs (descriptor-reg))
- (nfp :scs (descriptor-reg))
- (nsp :scs (descriptor-reg)))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 13
(load-symbol-value catch *current-catch-block*)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (move nfp cur-nfp)))
+ (move nfp cur-nfp)))
(move nsp nsp-tn)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
- (nfp :scs (descriptor-reg))
- (nsp :scs (descriptor-reg)))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 10
(store-symbol-value catch *current-catch-block*)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (move cur-nfp nfp)))
+ (move cur-nfp nfp)))
(move nsp-tn nsp)))
(define-vop (current-stack-pointer)
;;;
(define-vop (make-catch-block)
(:args (tn)
- (tag :scs (any-reg descriptor-reg)))
+ (tag :scs (any-reg descriptor-reg)))
(:info entry-label)
(:results (block :scs (any-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(define-vop (nlx-entry)
(:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
- ; would be inserted before the LRA.
- (start)
- (count))
+ ; would be inserted before the LRA.
+ (start)
+ (count))
(:results (values :more t))
(:temporary (:scs (descriptor-reg)) move-temp)
(:info label nvals)
(emit-return-pc label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
- ((= nvals 1)
- (let ((no-values (gen-label)))
- (inst cmpwi count 0)
- (move (tn-ref-tn values) null-tn)
- (inst beq no-values)
- (loadw (tn-ref-tn values) start)
- (emit-label no-values)))
- (t
- (collect ((defaults))
- (inst addic. count count (- (fixnumize 1)))
- (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 subi count count (fixnumize 1))
- (inst blt default-lab)
- (sc-case tn
- ((descriptor-reg any-reg)
- (loadw tn start i))
- (control-stack
- (loadw move-temp start i)
- (store-stack-tn tn move-temp)))
+ ((= nvals 1)
+ (let ((no-values (gen-label)))
+ (inst cmpwi count 0)
+ (move (tn-ref-tn values) null-tn)
+ (inst beq no-values)
+ (loadw (tn-ref-tn values) start)
+ (emit-label no-values)))
+ (t
+ (collect ((defaults))
+ (inst addic. count count (- (fixnumize 1)))
+ (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 subi count count (fixnumize 1))
+ (inst blt default-lab)
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (loadw tn start i))
+ (control-stack
+ (loadw move-temp start i)
+ (store-stack-tn tn move-temp)))
(inst cmpwi count 0)))
-
- (let ((defaulting-done (gen-label)))
-
- (emit-label defaulting-done)
-
- (assemble (*elsewhere*)
- (dolist (def (defaults))
- (emit-label (car def))
- (let ((tn (cdr def)))
- (sc-case tn
- ((descriptor-reg any-reg)
- (move tn null-tn))
- (control-stack
- (store-stack-tn tn null-tn)))))
- (inst b defaulting-done))))))
+
+ (let ((defaulting-done (gen-label)))
+
+ (emit-label defaulting-done)
+
+ (assemble (*elsewhere*)
+ (dolist (def (defaults))
+ (emit-label (car def))
+ (let ((tn (cdr def)))
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (move tn null-tn))
+ (control-stack
+ (store-stack-tn tn null-tn)))))
+ (inst b defaulting-done))))))
(load-stack-tn csp-tn sp)))
(:temporary (:scs (any-reg)) dst)
(:temporary (:scs (descriptor-reg)) temp)
(:results (result :scs (any-reg) :from (:argument 0))
- (num :scs (any-reg) :from (:argument 0)))
+ (num :scs (any-reg) :from (:argument 0)))
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-return-pc label)
(note-this-location vop :non-local-entry)
(let ((loop (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
;; Setup results, and test for the zero value case.
(load-stack-tn result top)
;;;; This file contains some parameterizations of various VM
-;;;; attributes for the PPC. This file is separate from other stuff so
-;;;; that it can be compiled and loaded earlier.
+;;;; attributes for the PPC. This file is separate from other stuff so
+;;;; that it can be compiled and loaded earlier.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(def!constant float-round-to-positive 2)
(def!constant float-round-to-negative 3)
-(defconstant-eqx float-rounding-mode (byte 2 0) #'equalp) ; RD
+(defconstant-eqx float-rounding-mode (byte 2 0) #'equalp) ; RD
;;; FIXME I: Beware, all ye who trespass here. Despite its name,
;;; FLOAT-STICKY-BITS is not the byte specifier for sticky bits in the
;;; floating point control word. It is more like "accrued exceptions"
;;; where FLOAT-EXCEPTIONS-BYTE is "current exceptions". Consequently,
;;; on architectures where there is no "current exceptions"
;;; FLOAT-EXCEPTIONS-BYTE and FLOAT-STICKY-BITS had better be the
-;;; same.
+;;; same.
;;;
;;; FIXME II: So, I've now documented this in comments in the PowerPC
;;; tree. This may not make it easy to find for when new architectures
;;; CSR, 2002-06-11
(defconstant-eqx float-sticky-bits (byte 5 25) #'equalp)
(defconstant-eqx float-traps-byte (byte 5 3) #'equalp)
-(defconstant-eqx float-exceptions-byte (byte 5 25) #'equalp) ; cexc
+(defconstant-eqx float-exceptions-byte (byte 5 25) #'equalp) ; cexc
-(def!constant float-fast-bit 2) ; Non-IEEE mode
+(def!constant float-fast-bit 2) ; Non-IEEE mode
\f
;;; Where to put the different spaces.
(def!constant static-space-start #x08000000)
(def!constant static-space-end #x097fff00)
-;;; nothing _seems_ to be using these addresses
+;;; nothing _seems_ to be using these addresses
(def!constant dynamic-0-space-start #x10000000)
(def!constant dynamic-0-space-end #x3ffff000)
(def!constant dynamic-1-space-start #x40000000)
sb!kernel:two-arg->
sb!kernel:two-arg-=
sb!kernel:two-arg-<=
- sb!kernel:two-arg->=
+ sb!kernel:two-arg->=
sb!kernel:two-arg-/=
eql
sb!kernel:%negate
;;;
;;; Converted by William Lott.
-;;;
+;;;
(in-package "SB!VM")
(define-vop (if-eq)
(:args (x :scs (any-reg descriptor-reg zero null))
- (y :scs (any-reg descriptor-reg zero null)))
+ (y :scs (any-reg descriptor-reg zero null)))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
;;;; 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.
(defun sanctify-for-execution (component)
(without-gcing
(alien-funcall (extern-alien "ppc_flush_icache"
- (function void
- system-area-pointer
- unsigned-long))
- (code-instructions component)
- (* (code-header-ref component code-code-size-slot)
- n-word-bytes)))
+ (function void
+ system-area-pointer
+ unsigned-long))
+ (code-instructions component)
+ (* (code-header-ref component code-code-size-slot)
+ n-word-bytes)))
nil)
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:results (res :scs (descriptor-reg)))
- (:note "SAP to pointer coercion")
+ (:note "SAP to pointer coercion")
(:generator 20
(with-fixed-allocation (res pa-flag ndescr sap-widetag sap-size)
(storew sap res sap-pointer-slot other-pointer-lowtag))))
;;; 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
(define-vop (pointer+)
(:translate sap+)
(:args (ptr :scs (sap-reg))
- (offset :scs (signed-reg)))
+ (offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(define-vop (pointer-)
(:translate sap-)
(:args (ptr1 :scs (sap-reg))
- (ptr2 :scs (sap-reg)))
+ (ptr2 :scs (sap-reg)))
(:arg-types system-area-pointer system-area-pointer)
(:policy :fast-safe)
(:results (res :scs (signed-reg)))
\f
;;;; 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")))
- `(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)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- (inst ,(ecase size
- (:byte 'lbzx)
- (:short (if signed 'lhax 'lhzx))
- (:long 'lwzx)
- (:single 'lfsx)
- (:double 'lfdx))
- result sap offset)
- ,@(when (and (eq size :byte) signed)
- '((inst extsb result result)))))
- (define-vop (,ref-name-c)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg)))
- (:arg-types system-area-pointer (:constant (signed-byte 16)))
- (:info offset)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- (inst ,(ecase size
- (:byte 'lbz)
- (:short (if signed 'lha 'lhz))
- (:long 'lwz)
- (:single 'lfs)
- (:double 'lfd))
- result sap offset)
- ,@(when (and (eq size :byte) signed)
- '((inst extsb result result)))))
- (define-vop (,set-name)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg))
- (offset :scs (signed-reg))
- (value :scs (,sc) :target result))
- (:arg-types system-area-pointer signed-num ,type)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- (inst ,(ecase size
- (:byte 'stbx)
- (:short 'sthx)
- (:long 'stwx)
- (:single 'stfsx)
- (:double 'stfdx))
- value sap offset)
- (unless (location= result value)
- ,@(case size
- (:single
- '((inst frsp result value)))
- (:double
- '((inst fmr result value)))
- (t
- '((inst mr result value)))))))
- (define-vop (,set-name-c)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg))
- (value :scs (,sc) :target result))
- (:arg-types system-area-pointer (:constant (signed-byte 16)) ,type)
- (:info offset)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- (inst ,(ecase size
- (:byte 'stb)
- (:short 'sth)
- (:long 'stw)
- (:single 'stfs)
- (:double 'stfd))
- value sap offset)
- (unless (location= result value)
- ,@(case size
- (:single
- '((inst frsp result value)))
- (:double
- '((inst fmr result value)))
- (t
- '((inst mr result value)))))))))))
+ (ref-name set-name sc type size &optional signed)
+ (let ((ref-name-c (symbolicate ref-name "-C"))
+ (set-name-c (symbolicate set-name "-C")))
+ `(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)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ (inst ,(ecase size
+ (:byte 'lbzx)
+ (:short (if signed 'lhax 'lhzx))
+ (:long 'lwzx)
+ (:single 'lfsx)
+ (:double 'lfdx))
+ result sap offset)
+ ,@(when (and (eq size :byte) signed)
+ '((inst extsb result result)))))
+ (define-vop (,ref-name-c)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg)))
+ (:arg-types system-area-pointer (:constant (signed-byte 16)))
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ (inst ,(ecase size
+ (:byte 'lbz)
+ (:short (if signed 'lha 'lhz))
+ (:long 'lwz)
+ (:single 'lfs)
+ (:double 'lfd))
+ result sap offset)
+ ,@(when (and (eq size :byte) signed)
+ '((inst extsb result result)))))
+ (define-vop (,set-name)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (offset :scs (signed-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer signed-num ,type)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ (inst ,(ecase size
+ (:byte 'stbx)
+ (:short 'sthx)
+ (:long 'stwx)
+ (:single 'stfsx)
+ (:double 'stfdx))
+ value sap offset)
+ (unless (location= result value)
+ ,@(case size
+ (:single
+ '((inst frsp result value)))
+ (:double
+ '((inst fmr result value)))
+ (t
+ '((inst mr result value)))))))
+ (define-vop (,set-name-c)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer (:constant (signed-byte 16)) ,type)
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ (inst ,(ecase size
+ (:byte 'stb)
+ (:short 'sth)
+ (:long 'stw)
+ (:single 'stfs)
+ (:double 'stfd))
+ value sap offset)
+ (unless (location= result value)
+ ,@(case size
+ (:single
+ '((inst frsp result value)))
+ (:double
+ '((inst fmr result value)))
+ (t
+ '((inst mr result value)))))))))))
(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
unsigned-reg positive-fixnum :byte nil)
(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
(:result-types system-area-pointer)
(:generator 2
(inst addi sap vector
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
\f
;;; Transforms for 64-bit SAP accessors.
(deftransform sap-ref-64 ((sap offset) (* *))
'(logior (ash (sap-ref-32 sap offset) 32)
- (sap-ref-32 sap (+ offset 4))))
+ (sap-ref-32 sap (+ offset 4))))
(deftransform signed-sap-ref-64 ((sap offset) (* *))
'(logior (ash (signed-sap-ref-32 sap offset) 32)
- (sap-ref-32 sap (+ 4 offset))))
+ (sap-ref-32 sap (+ 4 offset))))
(deftransform %set-sap-ref-64 ((sap offset value) (* * *))
'(progn
(:generator 100
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(move nl0 object)
(inst lr temp (make-fixup "call_into_c" :foreign))
(inst mr lip temp)
(inst lr cfunc (make-fixup "debug_print" :foreign))
(inst bctrl)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save))
+ (load-stack-tn cur-nfp nfp-save))
(move result nl0))))
(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*)
- ,@(when (< i num-args)
- `(:from (:argument ,i)))
- ,@(when (< i num-results)
- `(:to (:result ,i)
- :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*)
+ ,@(when (< i num-args)
+ `(:from (:argument ,i)))
+ ,@(when (< i num-results)
+ `(:to (:result ,i)
+ :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)
- (let ((lra-label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
- ,@(moves (temp-names) (arg-names))
- (inst lwz entry-point null-tn (static-fun-offset symbol))
- (inst lr nargs (fixnumize ,num-args))
- (when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
- (inst mr old-fp cfp-tn)
- (inst mr cfp-tn csp-tn)
- (inst compute-lra-from-code lra code-tn lra-label temp)
- (note-this-location vop :call-site)
- ;(inst mr code-tn func)
- (inst mtctr entry-point)
- (inst bctr)
- (emit-return-pc lra-label)
- ,(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 move-temp temp lra-label)))
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))
- ,@(moves (result-names) (temp-names))))))))
+ static-fun-template)
+ (:args ,@(args))
+ ,@(temps)
+ (:results ,@(results))
+ (:generator ,(+ 50 num-args num-results)
+ (let ((lra-label (gen-label))
+ (cur-nfp (current-nfp-tn vop)))
+ ,@(moves (temp-names) (arg-names))
+ (inst lwz entry-point null-tn (static-fun-offset symbol))
+ (inst lr nargs (fixnumize ,num-args))
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (inst mr old-fp cfp-tn)
+ (inst mr cfp-tn csp-tn)
+ (inst compute-lra-from-code lra code-tn lra-label temp)
+ (note-this-location vop :call-site)
+ ;(inst mr code-tn func)
+ (inst mtctr entry-point)
+ (inst bctr)
+ (emit-return-pc lra-label)
+ ,(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 move-temp temp lra-label)))
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))
+ ,@(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 5 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)))))
;;;
;;; Written by William Lott.
-;;;
+;;;
(in-package "SB!VM")
(:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
- count)
+ count)
(:results (result :scs (any-reg descriptor-reg)))
(:policy :fast-safe)
(:vop-var vop)
(:save-p :compute-only)
(:generator 50
(let ((done (gen-label))
- (loop (gen-label))
- (not-list (generate-cerror-code vop object-not-list-error object)))
+ (loop (gen-label))
+ (not-list (generate-cerror-code vop object-not-list-error object)))
(move ptr object)
(move count zero-tn)
(emit-label done)
(move result count))))
-
+
(define-static-fun length (object) :translate length)
;; It wasn't a fixnum, so get the low 8 bits.
(inst andi. result object widetag-mask)
(inst b done)
-
+
FUNCTION-POINTER
(load-type result object (- fun-pointer-lowtag))
(inst b done)
(:translate (setf fun-subtype))
(:policy :fast-safe)
(:args (type :scs (unsigned-reg) :target result)
- (function :scs (descriptor-reg)))
+ (function :scs (descriptor-reg)))
(:arg-types positive-fixnum *)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:translate set-header-data)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg) :target res)
- (data :scs (any-reg immediate zero)))
+ (data :scs (any-reg immediate zero)))
(:arg-types * positive-fixnum)
(:results (res :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) t1 t2)
(define-vop (make-other-immediate-type)
(:args (val :scs (any-reg descriptor-reg))
- (type :scs (any-reg descriptor-reg immediate)
- :target temp))
+ (type :scs (any-reg descriptor-reg immediate)
+ :target temp))
(:results (res :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 2
(define-vop (compute-fun)
(:args (code :scs (descriptor-reg))
- (offset :scs (signed-reg unsigned-reg)))
+ (offset :scs (signed-reg unsigned-reg)))
(:arg-types * positive-fixnum)
(:results (func :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (non-descriptor-reg)) count)
(:generator 1
(let ((offset
- (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
+ (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
(aver (typep offset '(signed-byte 16)))
(inst lwz count count-vector offset)
(inst addi count count 1)
(inst andi. temp value fixnum-tag-mask)
(inst beq (if not-p drop-through target)))
(%test-headers value target not-p nil headers
- :drop-through drop-through :temp temp)))
+ :drop-through drop-through :temp temp)))
(defun %test-immediate (value target not-p immediate &key temp)
(assemble ()
(inst b? (if not-p :ne :eq) target)))
(defun %test-headers (value target not-p function-p headers
- &key temp (drop-through (gen-label)))
+ &key temp (drop-through (gen-label)))
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind (when-true when-false)
(if not-p
(last (null (cdr remaining))))
(cond
((atom header)
- (cond
- ((and (not last) (null (cddr remaining))
- (atom (cadr remaining))
- (= (logcount (logxor header (cadr remaining))) 1))
- (inst andi. temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
- (inst cmpwi temp (ldb (byte 8 0) (logand header (cadr remaining))))
- (inst b? (if not-p :ne :eq) target)
- (return))
- (t
- (inst cmpwi temp header)
- (if last
- (inst b? (if not-p :ne :eq) target)
- (inst beq when-true)))))
+ (cond
+ ((and (not last) (null (cddr remaining))
+ (atom (cadr remaining))
+ (= (logcount (logxor header (cadr remaining))) 1))
+ (inst andi. temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
+ (inst cmpwi temp (ldb (byte 8 0) (logand header (cadr remaining))))
+ (inst b? (if not-p :ne :eq) target)
+ (return))
+ (t
+ (inst cmpwi temp header)
+ (if last
+ (inst b? (if not-p :ne :eq) target)
+ (inst beq when-true)))))
(t
(let ((start (car header))
(end (cdr header)))
- (cond
- ((and last (not (= start bignum-widetag))
- (= (+ start 4) end)
- (= (logcount (logxor start end)) 1))
- (inst andi. temp temp (ldb (byte 8 0) (logeqv start end)))
- (inst cmpwi temp (ldb (byte 8 0) (logand start end)))
- (inst b? (if not-p :ne :eq) 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))
- (inst andi. temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
- (inst cmpwi temp (ldb (byte 8 0) (logand start (cdadr remaining))))
- (inst b? (if not-p :ne :eq) target)
- (return))
- (t
- (unless (= start bignum-widetag)
- (inst cmpwi temp start)
- (if (= end complex-array-widetag)
- (progn
- (aver last)
- (inst b? (if not-p :lt :ge) target))
- (inst blt when-false)))
- (unless (= end complex-array-widetag)
- (inst cmpwi temp end)
- (if last
- (inst b? (if not-p :gt :le) target)
- (inst ble when-true))))))))))
+ (cond
+ ((and last (not (= start bignum-widetag))
+ (= (+ start 4) end)
+ (= (logcount (logxor start end)) 1))
+ (inst andi. temp temp (ldb (byte 8 0) (logeqv start end)))
+ (inst cmpwi temp (ldb (byte 8 0) (logand start end)))
+ (inst b? (if not-p :ne :eq) 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))
+ (inst andi. temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
+ (inst cmpwi temp (ldb (byte 8 0) (logand start (cdadr remaining))))
+ (inst b? (if not-p :ne :eq) target)
+ (return))
+ (t
+ (unless (= start bignum-widetag)
+ (inst cmpwi temp start)
+ (if (= end complex-array-widetag)
+ (progn
+ (aver last)
+ (inst b? (if not-p :lt :ge) target))
+ (inst blt when-false)))
+ (unless (= end complex-array-widetag)
+ (inst cmpwi temp end)
+ (if last
+ (inst b? (if not-p :gt :le) target)
+ (inst ble when-true))))))))))
(emit-label drop-through)))))
;;; Simple type checking and testing:
(defun cost-to-test-types (type-codes)
(+ (* 2 (length type-codes))
(if (> (apply #'max type-codes) lowtag-limit) 7 2)))
-
+
(defmacro !define-type-vops (pred-name check-name ptype error-code
- (&rest type-codes)
- ;; KLUDGE: ideally, the compiler could
- ;; derive that it can use the sneaky trap
- ;; twice mechanism itself. However, one
- ;; thing at a time...
- &key mask &allow-other-keys)
+ (&rest type-codes)
+ ;; KLUDGE: ideally, the compiler could
+ ;; derive that it can use the sneaky trap
+ ;; twice mechanism itself. However, one
+ ;; thing at a time...
+ &key mask &allow-other-keys)
(let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
`(progn
,@(when pred-name
- `((define-vop (,pred-name type-predicate)
- (:translate ,pred-name)
- (:generator ,cost
- (test-type value target not-p (,@type-codes) :temp temp)))))
+ `((define-vop (,pred-name type-predicate)
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value target not-p (,@type-codes) :temp temp)))))
,@(when check-name
- `((define-vop (,check-name check-type)
- (:generator ,cost
- ,@(if mask
- `((inst andi. temp value ,mask)
- (inst twi 0 value (error-number-or-lose ',error-code))
- (inst twi :ne temp ,@(ecase mask
- ((fixnum-tag-mask) `(0))
- ((lowtag-mask) type-codes)))
- (move result value))
- `((let ((err-lab
- (generate-error-code vop ,error-code value)))
- (test-type value err-lab t (,@type-codes) :temp temp)
- (move result value))))))))
+ `((define-vop (,check-name check-type)
+ (:generator ,cost
+ ,@(if mask
+ `((inst andi. temp value ,mask)
+ (inst twi 0 value (error-number-or-lose ',error-code))
+ (inst twi :ne temp ,@(ecase mask
+ ((fixnum-tag-mask) `(0))
+ ((lowtag-mask) type-codes)))
+ (move result value))
+ `((let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value err-lab t (,@type-codes) :temp temp)
+ (move result value))))))))
,@(when ptype
- `((primitive-type-vop ,check-name (:check) ,ptype))))))
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
\f
;;;; Other integer ranges.
(:generator 45
(let ((not-target (gen-label)))
(multiple-value-bind
- (yep nope)
- (if not-p
- (values not-target target)
- (values target not-target))
- (inst andi. temp value #x3)
- (inst beq yep)
- (test-type value nope t (other-pointer-lowtag) :temp temp)
- (loadw temp value 0 other-pointer-lowtag)
- (inst cmpwi temp (+ (ash 1 n-widetag-bits)
- bignum-widetag))
- (inst b? (if not-p :ne :eq) target)
- (emit-label not-target)))))
+ (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ (inst andi. temp value #x3)
+ (inst beq yep)
+ (test-type value nope t (other-pointer-lowtag) :temp temp)
+ (loadw temp value 0 other-pointer-lowtag)
+ (inst cmpwi temp (+ (ash 1 n-widetag-bits)
+ bignum-widetag))
+ (inst b? (if not-p :ne :eq) target)
+ (emit-label not-target)))))
(define-vop (check-signed-byte-32 check-type)
(:generator 45
(let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
- (yep (gen-label)))
+ (yep (gen-label)))
(inst andi. temp value #x3)
(inst beq yep)
(test-type value nope t (other-pointer-lowtag) :temp temp)
(: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?
- (inst andi. temp value #x3)
+ (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ ;; Is it a fixnum?
+ (inst andi. temp value #x3)
(inst cmpwi :cr1 value 0)
(inst beq fixnum)
- ;; If not, is it an other pointer?
- (test-type value nope t (other-pointer-lowtag) :temp temp)
- ;; Get the header.
- (loadw temp value 0 other-pointer-lowtag)
- ;; Is it one?
- (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
- (inst beq single-word)
- ;; If it's other than two, we can't be an (unsigned-byte 32)
- (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
- (inst bne nope)
- ;; Get the second digit.
- (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
- ;; All zeros, its an (unsigned-byte 32).
- (inst cmpwi temp 0)
- (inst beq yep)
- ;; Otherwise, it isn't.
- (inst b nope)
-
- (emit-label single-word)
- ;; Get the single digit.
- (loadw temp value bignum-digits-offset other-pointer-lowtag)
- (inst cmpwi :cr1 temp 0)
-
- ;; positive implies (unsigned-byte 32).
- (emit-label fixnum)
- (inst b? :cr1 (if not-p :lt :ge) target)
-
- (emit-label not-target)))))
+ ;; If not, is it an other pointer?
+ (test-type value nope t (other-pointer-lowtag) :temp temp)
+ ;; Get the header.
+ (loadw temp value 0 other-pointer-lowtag)
+ ;; Is it one?
+ (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (inst beq single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 32)
+ (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
+ (inst bne nope)
+ ;; Get the second digit.
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
+ ;; All zeros, its an (unsigned-byte 32).
+ (inst cmpwi temp 0)
+ (inst beq yep)
+ ;; Otherwise, it isn't.
+ (inst b nope)
+
+ (emit-label single-word)
+ ;; Get the single digit.
+ (loadw temp value bignum-digits-offset other-pointer-lowtag)
+ (inst cmpwi :cr1 temp 0)
+
+ ;; positive implies (unsigned-byte 32).
+ (emit-label fixnum)
+ (inst b? :cr1 (if not-p :lt :ge) 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?
(inst andi. temp value #x3)
(inst cmpwi :cr1 value 0)
(inst beq yep)
;; Otherwise, it isn't.
(inst b nope)
-
+
(emit-label single-word)
;; Get the single digit.
(loadw temp value bignum-digits-offset other-pointer-lowtag)
;; positive implies (unsigned-byte 32).
(inst cmpwi :cr1 temp 0)
-
+
(emit-label fixnum)
(inst blt :cr1 nope)
-
+
(emit-label yep)
(move result value))))
\f
;;;; List/symbol types:
-;;;
+;;;
;;; symbolp (or symbol (eq nil))
;;; consp (and list (not (eq nil)))
(:translate symbolp)
(:generator 12
(let* ((drop-thru (gen-label))
- (is-symbol-label (if not-p drop-thru target)))
+ (is-symbol-label (if not-p drop-thru target)))
(inst cmpw value null-tn)
(inst beq is-symbol-label)
(test-type value target not-p (symbol-header-widetag) :temp temp)
(define-vop (check-symbol check-type)
(:generator 12
(let ((drop-thru (gen-label))
- (error (generate-error-code vop object-not-symbol-error value)))
+ (error (generate-error-code vop object-not-symbol-error value)))
(inst cmpw value null-tn)
(inst beq drop-thru)
(test-type value error t (symbol-header-widetag) :temp temp)
(emit-label drop-thru)
(move result value))))
-
+
(define-vop (consp type-predicate)
(:translate consp)
(:generator 8
(let* ((drop-thru (gen-label))
- (is-not-cons-label (if not-p target drop-thru)))
+ (is-not-cons-label (if not-p target drop-thru)))
(inst cmpw value null-tn)
(inst beq is-not-cons-label)
(test-type value target not-p (list-pointer-lowtag) :temp temp)
;;; Written by Rob MacLachlan
;;;
;;; Converted for SPARC by William Lott.
-;;;
+;;;
(in-package "SB!VM")
(define-vop (push-values)
(:args (vals :more t))
(:results (start :scs (any-reg) :from :load)
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:info nvals)
(:temporary (:scs (descriptor-reg)) temp)
(:generator 20
(inst mr start csp-tn)
(inst addi csp-tn csp-tn (* nvals n-word-bytes))
(do ((val vals (tn-ref-across val))
- (i 0 (1+ i)))
- ((null val))
+ (i 0 (1+ i)))
+ ((null val))
(let ((tn (tn-ref-tn val)))
- (sc-case tn
- (descriptor-reg
- (storew tn start i))
- (control-stack
- (load-stack-tn temp tn)
- (storew temp start i)))))
+ (sc-case tn
+ (descriptor-reg
+ (storew tn start i))
+ (control-stack
+ (load-stack-tn temp tn)
+ (storew temp start i)))))
(inst lr count (fixnumize nvals))))
;;; Push a list of values on the stack, returning Start and Count as used in
(:arg-types list)
(:policy :fast-safe)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:save-p :compute-only)
(:generator 0
(let ((loop (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(move list arg)
(move start csp-tn)
;;;
(define-vop (%more-arg-values)
(:args (context :scs (descriptor-reg any-reg) :target src)
- (skip :scs (any-reg zero immediate))
- (num :scs (any-reg) :target count))
+ (skip :scs (any-reg zero immediate))
+ (num :scs (any-reg) :target count))
(:arg-types * positive-fixnum positive-fixnum)
(:temporary (:sc any-reg :from (:argument 0)) src)
(:temporary (:sc any-reg :from (:argument 2)) dst)
(:temporary (:sc descriptor-reg :from (:argument 1)) temp)
(:temporary (:sc any-reg) i)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:generator 20
(sc-case skip
(zero
;;; The number of bytes reserved above the number stack pointer. These
;;; slots are required by architecture, mostly (?) to make C backtrace
;;; work. This must be a power of 2 - see BYTES-REQUIRED-FOR-NUMBER-STACK.
-;;;
+;;;
(def!constant number-stack-displacement
(* #!-darwin 2
#!+darwin 8
`(eval-when (:compile-toplevel :load-toplevel :execute)
(def!constant ,offset-sym ,offset)
(setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
-
+
(defregset (name &rest regs)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter ,name
(defreg nl4 7)
(defreg nl5 8)
(defreg nl6 9)
- (defreg fdefn 10) ; was nl7
+ (defreg fdefn 10) ; was nl7
(defreg nargs 11)
;; FIXME: some kind of comment here would be nice.
;;
(defregset non-descriptor-regs
nl0 nl1 nl2 nl3 nl4 nl5 nl6 #+nil nl7 cfunc nargs nfp)
-
+
(defregset descriptor-regs
fdefn a0 a1 a2 a3 ocfp lra cname lexenv l0 l1 l2 )
-
+
(defregset *register-arg-offsets* a0 a1 a2 a3)
(defparameter register-arg-names '(a0 a1 a2 a3)))
;;;
;;; Handy macro so we don't have to keep changing all the numbers whenever
;;; we insert a new storage class.
-;;;
+;;;
(defmacro define-storage-classes (&rest classes)
(do ((forms (list 'progn)
- (let* ((class (car classes))
- (sc-name (car class))
- (constant-name (intern (concatenate 'simple-string
- (string sc-name)
- "-SC-NUMBER"))))
- (list* `(define-storage-class ,sc-name ,index
- ,@(cdr class))
- `(def!constant ,constant-name ,index)
- forms)))
+ (let* ((class (car classes))
+ (sc-name (car class))
+ (constant-name (intern (concatenate 'simple-string
+ (string sc-name)
+ "-SC-NUMBER"))))
+ (list* `(define-storage-class ,sc-name ,index
+ ,@(cdr class))
+ `(def!constant ,constant-name ,index)
+ forms)))
(index 0 (1+ index))
(classes classes (cdr classes)))
((null classes)
(sap-stack non-descriptor-stack) ; System area pointers.
(single-stack non-descriptor-stack) ; single-floats
(double-stack non-descriptor-stack
- :element-size 2 :alignment 2) ; double floats.
+ :element-size 2 :alignment 2) ; double floats.
(complex-single-stack non-descriptor-stack :element-size 2)
(complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
(defregtn null descriptor-reg)
(defregtn code descriptor-reg)
(defregtn alloc any-reg)
-
+
(defregtn nargs any-reg)
(defregtn bsp any-reg)
(defregtn csp any-reg)
(null
(sc-number-or-lose 'null))
((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
- system-area-pointer character)
+ system-area-pointer character)
(sc-number-or-lose 'immediate))
(symbol
(if (static-symbol-p value)
- (sc-number-or-lose 'immediate)
- nil))))
+ (sc-number-or-lose 'immediate)
+ nil))))
\f
;;;; function call parameters
;;;
(defparameter *register-arg-tns*
(mapcar #'(lambda (n)
- (make-random-tn :kind :normal
- :sc (sc-or-lose 'descriptor-reg)
- :offset n))
- *register-arg-offsets*))
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset n))
+ *register-arg-offsets*))
(export 'single-value-return-byte-offset)
(!def-vm-support-routine location-print-name (tn)
(declare (type tn tn))
(let ((sb (sb-name (sc-sb (tn-sc tn))))
- (offset (tn-offset tn)))
+ (offset (tn-offset tn)))
(ecase sb
(registers (or (svref *register-names* offset)
- (format nil "R~D" offset)))
+ (format nil "R~D" offset)))
(float-registers (format nil "F~D" offset))
(control-stack (format nil "CS~D" offset))
(non-descriptor-stack (format nil "NS~D" offset))
(:temporary (:scs (descriptor-reg) :type list) ptr)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
- res)
+ res)
(:info num)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:node-var node)
(:generator 0
(cond ((zerop num)
- (move result null-tn))
- ((and star (= num 1))
- (move result (tn-ref-tn things)))
- (t
- (macrolet
- ((maybe-load (tn)
- (once-only ((tn tn))
- `(sc-case ,tn
- ((any-reg descriptor-reg zero null)
- ,tn)
- (control-stack
- (load-stack-tn temp ,tn)
- temp)))))
- (let* ((dx-p (node-stack-allocate-p node))
- (cons-cells (if star (1- num) num))
- (alloc (* (pad-data-block cons-size) cons-cells)))
- (pseudo-atomic (:extra (if dx-p 0 alloc))
- (let ((allocation-area-tn (if dx-p csp-tn alloc-tn)))
- (when dx-p
- (align-csp res))
- (inst andn res allocation-area-tn lowtag-mask)
- (inst or res list-pointer-lowtag)
- (when dx-p
- (inst add csp-tn csp-tn alloc)))
- (move ptr res)
- (dotimes (i (1- cons-cells))
- (storew (maybe-load (tn-ref-tn things)) ptr
- cons-car-slot list-pointer-lowtag)
- (setf things (tn-ref-across things))
- (inst add ptr ptr (pad-data-block cons-size))
- (storew ptr ptr
- (- cons-cdr-slot cons-size)
- list-pointer-lowtag))
- (storew (maybe-load (tn-ref-tn things)) ptr
- cons-car-slot list-pointer-lowtag)
- (storew (if star
- (maybe-load (tn-ref-tn (tn-ref-across things)))
- null-tn)
- ptr cons-cdr-slot list-pointer-lowtag))
- (move result res)))))))
+ (move result null-tn))
+ ((and star (= num 1))
+ (move result (tn-ref-tn things)))
+ (t
+ (macrolet
+ ((maybe-load (tn)
+ (once-only ((tn tn))
+ `(sc-case ,tn
+ ((any-reg descriptor-reg zero null)
+ ,tn)
+ (control-stack
+ (load-stack-tn temp ,tn)
+ temp)))))
+ (let* ((dx-p (node-stack-allocate-p node))
+ (cons-cells (if star (1- num) num))
+ (alloc (* (pad-data-block cons-size) cons-cells)))
+ (pseudo-atomic (:extra (if dx-p 0 alloc))
+ (let ((allocation-area-tn (if dx-p csp-tn alloc-tn)))
+ (when dx-p
+ (align-csp res))
+ (inst andn res allocation-area-tn lowtag-mask)
+ (inst or res list-pointer-lowtag)
+ (when dx-p
+ (inst add csp-tn csp-tn alloc)))
+ (move ptr res)
+ (dotimes (i (1- cons-cells))
+ (storew (maybe-load (tn-ref-tn things)) ptr
+ cons-car-slot list-pointer-lowtag)
+ (setf things (tn-ref-across things))
+ (inst add ptr ptr (pad-data-block cons-size))
+ (storew ptr ptr
+ (- cons-cdr-slot cons-size)
+ list-pointer-lowtag))
+ (storew (maybe-load (tn-ref-tn things)) ptr
+ cons-car-slot list-pointer-lowtag)
+ (storew (if star
+ (maybe-load (tn-ref-tn (tn-ref-across things)))
+ null-tn)
+ ptr cons-cdr-slot list-pointer-lowtag))
+ (move result res)))))))
(define-vop (list list-or-list*)
(:variant nil))
(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg))
- (unboxed-arg :scs (any-reg)))
+ (unboxed-arg :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed)
(:results (result :scs (descriptor-reg)))
(:generator 10
(let* ((size (+ length closure-info-offset))
- (alloc-size (pad-data-block size)))
+ (alloc-size (pad-data-block size)))
(pseudo-atomic (:extra (if stack-allocate-p 0 alloc-size))
- (cond (stack-allocate-p
- (align-csp temp)
- (inst andn result csp-tn lowtag-mask)
- (inst or result fun-pointer-lowtag)
- (inst add csp-tn alloc-size))
- (t
- (inst andn result alloc-tn lowtag-mask)
- (inst or result fun-pointer-lowtag)))
- (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
- (storew temp result 0 fun-pointer-lowtag))
+ (cond (stack-allocate-p
+ (align-csp temp)
+ (inst andn result csp-tn lowtag-mask)
+ (inst or result fun-pointer-lowtag)
+ (inst add csp-tn alloc-size))
+ (t
+ (inst andn result alloc-tn lowtag-mask)
+ (inst or result fun-pointer-lowtag)))
+ (inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
+ (storew temp result 0 fun-pointer-lowtag))
(storew function result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (result :scs (descriptor-reg)))
(:generator 10
- (with-fixed-allocation
+ (with-fixed-allocation
(result temp value-cell-header-widetag value-cell-size)
(storew value result value-cell-value-slot other-pointer-lowtag))))
\f
(:generator 4
(pseudo-atomic (:extra (pad-data-block words))
(cond ((logbitp (1- n-lowtag-bits) lowtag)
- (inst or result alloc-tn lowtag))
- (t
- (inst andn result alloc-tn lowtag-mask)
- (inst or result lowtag)))
+ (inst or result alloc-tn lowtag))
+ (t
+ (inst andn result alloc-tn lowtag-mask)
+ (inst or result lowtag)))
(when type
- (inst li temp (logior (ash (1- words) n-widetag-bits) type))
- (storew temp result 0 lowtag)))))
+ (inst li temp (logior (ash (1- words) n-widetag-bits) type))
+ (storew temp result 0 lowtag)))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
;; Need to be careful if the lowtag and the pseudo-atomic flag
;; are not compatible.
(cond ((logbitp (1- n-lowtag-bits) lowtag)
- (inst or result alloc-tn lowtag))
- (t
- (inst andn result alloc-tn lowtag-mask)
- (inst or result lowtag)))
+ (inst or result alloc-tn lowtag))
+ (t
+ (inst andn result alloc-tn lowtag-mask)
+ (inst or result lowtag)))
(storew header result 0 lowtag)
(inst add alloc-tn alloc-tn bytes))))
(define-vop (fast-fixnum-binop fast-safe-arith-op)
(:args (x :target r :scs (any-reg zero))
- (y :target r :scs (any-reg zero)))
+ (y :target r :scs (any-reg zero)))
(:arg-types tagged-num tagged-num)
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(define-vop (fast-unsigned-binop fast-safe-arith-op)
(:args (x :target r :scs (unsigned-reg zero))
- (y :target r :scs (unsigned-reg zero)))
+ (y :target r :scs (unsigned-reg zero)))
(:arg-types unsigned-num unsigned-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(define-vop (fast-signed-binop fast-safe-arith-op)
(:args (x :target r :scs (signed-reg zero))
- (y :target r :scs (signed-reg zero)))
+ (y :target r :scs (signed-reg zero)))
(:arg-types signed-num signed-num)
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:args (x :target r :scs (any-reg zero)))
(:info y)
(:arg-types tagged-num
- (:constant (and (signed-byte 11) (not (integer 0 0)))))
+ (:constant (and (signed-byte 11) (not (integer 0 0)))))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:note "inline fixnum arithmetic"))
(:args (x :target r :scs (unsigned-reg zero)))
(:info y)
(:arg-types unsigned-num
- (:constant (and (signed-byte 13) (not (integer 0 0)))))
+ (:constant (and (signed-byte 13) (not (integer 0 0)))))
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "inline (unsigned-byte 32) arithmetic"))
(:args (x :target r :scs (signed-reg zero)))
(:info y)
(:arg-types signed-num
- (:constant (and (signed-byte 13) (not (integer 0 0)))))
+ (:constant (and (signed-byte 13) (not (integer 0 0)))))
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:note "inline (signed-byte 32) arithmetic"))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro define-binop (translate untagged-penalty op
- &optional arg-swap restore-fixnum-mask)
+ &optional arg-swap restore-fixnum-mask)
`(progn
(define-vop (,(symbolicate 'fast translate '/fixnum=>fixnum)
- fast-fixnum-binop)
+ fast-fixnum-binop)
,@(when restore-fixnum-mask
- `((:temporary (:sc non-descriptor-reg) temp)))
+ `((:temporary (:sc non-descriptor-reg) temp)))
(:translate ,translate)
(:generator 2
- ,(if arg-swap
- `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
- `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
- ,@(when restore-fixnum-mask
- `((inst andn r temp fixnum-tag-mask)))))
+ ,(if arg-swap
+ `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
+ `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
+ ,@(when restore-fixnum-mask
+ `((inst andn r temp fixnum-tag-mask)))))
,@(unless arg-swap
- `((define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
- fast-fixnum-binop-c)
- ,@(when restore-fixnum-mask
- `((:temporary (:sc non-descriptor-reg) temp)))
- (:translate ,translate)
- (:generator 1
- (inst ,op ,(if restore-fixnum-mask 'temp 'r) x (fixnumize y))
- ,@(when restore-fixnum-mask
- `((inst andn r temp fixnum-tag-mask)))))))
+ `((define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+ fast-fixnum-binop-c)
+ ,@(when restore-fixnum-mask
+ `((:temporary (:sc non-descriptor-reg) temp)))
+ (:translate ,translate)
+ (:generator 1
+ (inst ,op ,(if restore-fixnum-mask 'temp 'r) x (fixnumize y))
+ ,@(when restore-fixnum-mask
+ `((inst andn r temp fixnum-tag-mask)))))))
(define-vop (,(symbolicate 'fast- translate '/signed=>signed)
- fast-signed-binop)
+ fast-signed-binop)
(:translate ,translate)
(:generator ,(1+ untagged-penalty)
- ,(if arg-swap
- `(inst ,op r y x)
- `(inst ,op r x y))))
+ ,(if arg-swap
+ `(inst ,op r y x)
+ `(inst ,op r x y))))
,@(unless arg-swap
- `((define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
- fast-signed-binop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (inst ,op r x y)))))
+ `((define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+ fast-signed-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (inst ,op r x y)))))
(define-vop (,(symbolicate 'fast- translate '/unsigned=>unsigned)
- fast-unsigned-binop)
+ fast-unsigned-binop)
(:translate ,translate)
(:generator ,(1+ untagged-penalty)
- ,(if arg-swap
- `(inst ,op r y x)
- `(inst ,op r x y))))
+ ,(if arg-swap
+ `(inst ,op r y x)
+ `(inst ,op r x y))))
,@(unless arg-swap
- `((define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
- fast-unsigned-binop-c)
- (:translate ,translate)
- (:generator ,untagged-penalty
- (inst ,op r x y)))))))
+ `((define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
+ fast-unsigned-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (inst ,op r x y)))))))
); eval-when
(define-vop (fast-v8-truncate/fixnum=>fixnum fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (any-reg))
- (y :scs (any-reg)))
+ (y :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:results (quo :scs (any-reg))
- (rem :scs (any-reg)))
+ (rem :scs (any-reg)))
(:result-types tagged-num tagged-num)
(:note "inline fixnum arithmetic")
(:temporary (:scs (any-reg) :target quo) q)
(:vop-var vop)
(:save-p :compute-only)
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (and (member :sparc-v9 *backend-subfeatures*)
- (not (member :sparc-64 *backend-subfeatures*)))))
+ (and (member :sparc-v9 *backend-subfeatures*)
+ (not (member :sparc-64 *backend-subfeatures*)))))
(:generator 12
(let ((zero (generate-error-code vop division-by-zero-error x y)))
(inst cmp y zero-tn)
(inst nop)
(inst nop)
- (inst sdiv q x y-int) ; Q is tagged.
+ (inst sdiv q x y-int) ; Q is tagged.
;; We have the quotient so we need to compute the remainder
- (inst smul r q y-int) ; R is tagged
+ (inst smul r q y-int) ; R is tagged
(inst sub rem x r)
(unless (location= quo q)
- (move quo q)))))
+ (move quo q)))))
(define-vop (fast-v8-truncate/signed=>signed fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (signed-reg))
- (y :scs (signed-reg)))
+ (y :scs (signed-reg)))
(:arg-types signed-num signed-num)
(: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")
(:temporary (:scs (signed-reg) :target quo) q)
(:vop-var vop)
(:save-p :compute-only)
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (and (member :sparc-v9 *backend-subfeatures*)
- (not (member :sparc-64 *backend-subfeatures*)))))
+ (and (member :sparc-v9 *backend-subfeatures*)
+ (not (member :sparc-64 *backend-subfeatures*)))))
(:generator 12
(let ((zero (generate-error-code vop division-by-zero-error x y)))
(inst cmp y zero-tn)
(if (member :sparc-v9 *backend-subfeatures*)
- (inst b :eq zero :pn)
- (inst b :eq zero))
+ (inst b :eq zero :pn)
+ (inst b :eq zero))
;; Extend the sign of X into the Y register
(inst sra r x 31)
(inst wry r)
(inst sdiv q x y)
;; We have the quotient so we need to compue the remainder
- (inst smul r q y) ; rem
+ (inst smul r q y) ; rem
(inst sub rem x r)
(unless (location= quo q)
- (move quo q)))))
+ (move quo q)))))
(define-vop (fast-v8-truncate/unsigned=>unsigned fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (unsigned-reg))
- (y :scs (unsigned-reg)))
+ (y :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(: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")
(:temporary (:scs (unsigned-reg) :target quo) q)
(:vop-var vop)
(:save-p :compute-only)
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (and (member :sparc-v9 *backend-subfeatures*)
- (not (member :sparc-64 *backend-subfeatures*)))))
+ (and (member :sparc-v9 *backend-subfeatures*)
+ (not (member :sparc-64 *backend-subfeatures*)))))
(:generator 8
(let ((zero (generate-error-code vop division-by-zero-error x y)))
(inst cmp y zero-tn)
(if (member :sparc-v9 *backend-subfeatures*)
- (inst b :eq zero :pn)
- (inst b :eq zero))
- (inst wry zero-tn) ; Clear out high part
+ (inst b :eq zero :pn)
+ (inst b :eq zero))
+ (inst wry zero-tn) ; Clear out high part
(inst nop)
(inst nop)
(inst nop)
-
+
(inst udiv q x y)
;; Compute remainder
(inst umul r q y)
(inst sub rem x r)
(unless (location= quo q)
- (inst move quo q)))))
+ (inst move quo q)))))
(define-vop (fast-v9-truncate/signed=>signed fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (signed-reg))
- (y :scs (signed-reg)))
+ (y :scs (signed-reg)))
(:arg-types signed-num signed-num)
(: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")
(:temporary (:scs (signed-reg) :target quo) q)
(inst mulx r q y)
(inst sub rem x r)
(unless (location= quo q)
- (inst move quo q)))))
+ (inst move quo q)))))
(define-vop (fast-v9-truncate/unsigned=>unsigned fast-safe-arith-op)
(:translate truncate)
(:args (x :scs (unsigned-reg))
- (y :scs (unsigned-reg)))
+ (y :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num)
(: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")
(:temporary (:scs (unsigned-reg) :target quo) q)
(inst mulx r q y)
(inst sub rem x r)
(unless (location= quo q)
- (inst move quo q)))))
+ (inst move quo q)))))
;;; Shifting
(define-vop (fast-ash/signed=>signed)
(:note "inline ASH")
(:args (number :scs (signed-reg) :to :save)
- (amount :scs (signed-reg) :to :save))
+ (amount :scs (signed-reg) :to :save))
(:arg-types signed-num signed-num)
(:results (result :scs (signed-reg)))
(:result-types signed-num)
(inst neg ndesc amount)
(inst cmp ndesc 31)
(if (member :sparc-v9 *backend-subfeatures*)
- (progn
- (inst cmove :ge ndesc 31)
- (inst sra result number ndesc))
- (progn
- (inst b :le done)
- (inst sra result number ndesc)
- (inst sra result number 31)))
+ (progn
+ (inst cmove :ge ndesc 31)
+ (inst sra result number ndesc))
+ (progn
+ (inst b :le done)
+ (inst sra result number ndesc)
+ (inst sra result number 31)))
(emit-label done))))
(define-vop (fast-ash-c/signed=>signed)
(define-vop (fast-ash/unsigned=>unsigned)
(:note "inline ASH")
(:args (number :scs (unsigned-reg) :to :save)
- (amount :scs (signed-reg) :to :save))
+ (amount :scs (signed-reg) :to :save))
(:arg-types unsigned-num signed-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(inst neg ndesc amount)
(inst cmp ndesc 32)
(if (member :sparc-v9 *backend-subfeatures*)
- (progn
- (inst srl result number ndesc)
- (inst cmove :ge result zero-tn))
- (progn
- (inst b :lt done)
- (inst srl result number ndesc)
- (move result zero-tn)))
+ (progn
+ (inst srl result number ndesc)
+ (inst cmove :ge result zero-tn))
+ (progn
+ (inst b :lt done)
+ (inst srl result number ndesc)
+ (move result zero-tn)))
(emit-label done))))
(define-vop (fast-ash-c/unsigned=>unsigned)
(macrolet
((def (name sc-type type result-type cost)
`(define-vop (,name)
- (:note "inline ASH")
- (:translate ash)
- (:args (number :scs (,sc-type))
- (amount :scs (signed-reg unsigned-reg immediate)))
- (:arg-types ,type positive-fixnum)
- (:results (result :scs (,result-type)))
- (:result-types ,type)
- (:policy :fast-safe)
- (:generator ,cost
- ;; The result-type assures us that this shift will not
- ;; overflow. And for fixnums, the zero bits that get
- ;; shifted in are just fine for the fixnum tag.
- (sc-case amount
- ((signed-reg unsigned-reg)
- (inst sll result number amount))
- (immediate
- (let ((amount (tn-value amount)))
- (aver (>= amount 0))
- (inst sll result number amount))))))))
+ (:note "inline ASH")
+ (:translate ash)
+ (:args (number :scs (,sc-type))
+ (amount :scs (signed-reg unsigned-reg immediate)))
+ (:arg-types ,type positive-fixnum)
+ (:results (result :scs (,result-type)))
+ (:result-types ,type)
+ (:policy :fast-safe)
+ (:generator ,cost
+ ;; The result-type assures us that this shift will not
+ ;; overflow. And for fixnums, the zero bits that get
+ ;; shifted in are just fine for the fixnum tag.
+ (sc-case amount
+ ((signed-reg unsigned-reg)
+ (inst sll result number amount))
+ (immediate
+ (let ((amount (tn-value amount)))
+ (aver (>= amount 0))
+ (inst sll result number amount))))))))
(def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
(def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
(def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
(:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
(:generator 30
(let ((loop (gen-label))
- (test (gen-label)))
+ (test (gen-label)))
(inst addcc shift zero-tn arg)
(inst b :ge test)
(move res zero-tn)
(emit-label loop)
(inst add res (fixnumize 1))
-
+
(emit-label test)
(inst cmp shift)
(inst b :ne loop)
(move res arg)
(dolist (stuff '((1 #x55555555) (2 #x33333333) (4 #x0f0f0f0f)
- (8 #x00ff00ff) (16 #x0000ffff)))
- (destructuring-bind (shift bit-mask)
- stuff
- ;; Set mask
- (inst sethi mask (ldb (byte 22 10) bit-mask))
- (inst add mask (ldb (byte 10 0) bit-mask))
+ (8 #x00ff00ff) (16 #x0000ffff)))
+ (destructuring-bind (shift bit-mask)
+ stuff
+ ;; Set mask
+ (inst sethi mask (ldb (byte 22 10) bit-mask))
+ (inst add mask (ldb (byte 10 0) bit-mask))
- (inst and temp res mask)
- (inst srl res shift)
- (inst and res mask)
- (inst add res temp)))))
+ (inst and temp res mask)
+ (inst srl res shift)
+ (inst and res mask)
+ (inst add res temp)))))
;;; Multiply and Divide.
(:temporary (:scs (non-descriptor-reg)) temp)
(:translate *)
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (and (member :sparc-v9 *backend-subfeatures*)
- (not (member :sparc-64 *backend-subfeatures*)))))
+ (and (member :sparc-v9 *backend-subfeatures*)
+ (not (member :sparc-64 *backend-subfeatures*)))))
(:generator 2
;; The cost here should be less than the cost for
;; */signed=>signed. Why? A fixnum product using signed=>signed
(:args (x :target r :scs (any-reg zero)))
(:info y)
(:arg-types tagged-num
- (:constant (and (signed-byte 13) (not (integer 0 0)))))
+ (:constant (and (signed-byte 13) (not (integer 0 0)))))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:note "inline fixnum arithmetic")
(:translate *)
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (and (member :sparc-v9 *backend-subfeatures*)
- (not (member :sparc-64 *backend-subfeatures*)))))
+ (and (member :sparc-v9 *backend-subfeatures*)
+ (not (member :sparc-64 *backend-subfeatures*)))))
(:generator 1
(inst smul r x y)))
(define-vop (fast-v8-*/signed=>signed fast-signed-binop)
(:translate *)
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (and (member :sparc-v9 *backend-subfeatures*)
- (not (member :sparc-64 *backend-subfeatures*)))))
+ (and (member :sparc-v9 *backend-subfeatures*)
+ (not (member :sparc-64 *backend-subfeatures*)))))
(:generator 3
(inst smul r x y)))
(define-vop (fast-v8-*-c/signed=>signed fast-signed-binop-c)
(:translate *)
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (and (member :sparc-v9 *backend-subfeatures*)
- (not (member :sparc-64 *backend-subfeatures*)))))
+ (and (member :sparc-v9 *backend-subfeatures*)
+ (not (member :sparc-64 *backend-subfeatures*)))))
(:generator 2
(inst smul r x y)))
-
+
(define-vop (fast-v8-*/unsigned=>unsigned fast-unsigned-binop)
(:translate *)
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (and (member :sparc-v9 *backend-subfeatures*)
- (not (member :sparc-64 *backend-subfeatures*)))))
+ (and (member :sparc-v9 *backend-subfeatures*)
+ (not (member :sparc-64 *backend-subfeatures*)))))
(:generator 3
(inst umul r x y)))
(define-vop (fast-v8-*-c/unsigned=>unsigned fast-unsigned-binop-c)
(:translate *)
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (and (member :sparc-v9 *backend-subfeatures*)
- (not (member :sparc-64 *backend-subfeatures*)))))
+ (and (member :sparc-v9 *backend-subfeatures*)
+ (not (member :sparc-64 *backend-subfeatures*)))))
(:generator 2
(inst umul r x y)))
(define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
(define-vop (,modvop ,vop)
(:translate ,mfun-name))
- ,@(when constantp
- `((define-vop (,modcvop ,cvop)
- (:translate ,mfun-name))))))))
+ ,@(when constantp
+ `((define-vop (,modcvop ,cvop)
+ (:translate ,mfun-name))))))))
(define-modular-backend + t)
(define-modular-backend - t)
(define-modular-backend logxor t)
`(lognot (logior ,x ,y)))
(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
- fast-ash-c/unsigned=>unsigned)
+ fast-ash-c/unsigned=>unsigned)
(:translate ash-left-mod32))
(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-vop (fast-conditional/fixnum fast-conditional)
(:args (x :scs (any-reg zero))
- (y :scs (any-reg zero)))
+ (y :scs (any-reg zero)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison"))
(define-vop (fast-conditional/signed fast-conditional)
(:args (x :scs (signed-reg zero))
- (y :scs (signed-reg zero)))
+ (y :scs (signed-reg zero)))
(:arg-types signed-num signed-num)
(:note "inline (signed-byte 32) comparison"))
(define-vop (fast-conditional/unsigned fast-conditional)
(:args (x :scs (unsigned-reg zero))
- (y :scs (unsigned-reg zero)))
+ (y :scs (unsigned-reg zero)))
(:arg-types unsigned-num unsigned-num)
(:note "inline (unsigned-byte 32) comparison"))
(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned)
`(progn
,@(mapcar (lambda (suffix cost signed)
- (unless (and (member suffix '(/fixnum -c/fixnum))
- (eq tran 'eql))
- `(define-vop (,(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 b (if not-p
- ,(if signed not-cond not-unsigned)
- ,(if signed cond unsigned))
- target)
- (inst nop)))))
- '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
- '(4 3 6 5 6 5)
- '(t t t t nil nil))))
+ (unless (and (member suffix '(/fixnum -c/fixnum))
+ (eq tran 'eql))
+ `(define-vop (,(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 b (if not-p
+ ,(if signed not-cond not-unsigned)
+ ,(if signed cond unsigned))
+ target)
+ (inst nop)))))
+ '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+ '(4 3 6 5 6 5)
+ '(t t t t nil nil))))
(define-conditional-vop < :lt :ltu :ge :geu)
(define-vop (fast-eql/fixnum fast-conditional)
(:args (x :scs (any-reg descriptor-reg zero))
- (y :scs (any-reg zero)))
+ (y :scs (any-reg zero)))
(:arg-types tagged-num tagged-num)
(:note "inline fixnum comparison")
(:translate eql)
(define-vop (merge-bits)
(:translate merge-bits)
(:args (shift :scs (signed-reg unsigned-reg))
- (prev :scs (unsigned-reg))
- (next :scs (unsigned-reg)))
+ (prev :scs (unsigned-reg))
+ (next :scs (unsigned-reg)))
(:arg-types tagged-num unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
(define-vop (shift-towards-someplace)
(:policy :fast-safe)
(:args (num :scs (unsigned-reg))
- (amount :scs (signed-reg)))
+ (amount :scs (signed-reg)))
(:arg-types unsigned-num tagged-num)
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num))
(:variant bignum-digits-offset other-pointer-lowtag)
(:translate sb!bignum:%bignum-set)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg immediate zero))
- (value :scs (unsigned-reg)))
+ (index :scs (any-reg immediate zero))
+ (value :scs (unsigned-reg)))
(:arg-types t positive-fixnum unsigned-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num))
(:translate sb!bignum:%add-with-carry)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
- (b :scs (unsigned-reg))
- (c :scs (any-reg)))
+ (b :scs (unsigned-reg))
+ (c :scs (any-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg))
- (carry :scs (unsigned-reg)))
+ (carry :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 3
(inst addcc zero-tn c -1)
(:translate sb!bignum:%subtract-with-borrow)
(:policy :fast-safe)
(:args (a :scs (unsigned-reg))
- (b :scs (unsigned-reg))
- (c :scs (any-reg)))
+ (b :scs (unsigned-reg))
+ (c :scs (any-reg)))
(:arg-types unsigned-num unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg))
- (borrow :scs (unsigned-reg)))
+ (borrow :scs (unsigned-reg)))
(:result-types unsigned-num positive-fixnum)
(:generator 4
(inst subcc zero-tn c 1)
;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly
;;; routines.
-;;;
+;;;
(defun emit-multiply (multiplier multiplicand result-high result-low)
"Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result
in RESULT-HIGH and RESULT-LOW. KIND is either :signed or :unsigned.
Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap."
(declare (type tn multiplier result-high result-low)
- (type (or tn (signed-byte 13)) multiplicand))
+ (type (or tn (signed-byte 13)) multiplicand))
;; It seems that emit-multiply is only used to do an unsigned
;; multiply, so the code only does an unsigned multiply.
(cond
;; unsigned 64-bit numbers.
(inst srl multiplier 0)
(inst srl multiplicand 0)
-
+
;; Multiply the two numbers and put the result in
;; result-high. Copy the low 32-bits to result-low. Then
;; shift result-high so the high 32-bits end up in the low
(inst move result-low result-high)
(inst srax result-high 32))
((or (member :sparc-v8 *backend-subfeatures*)
- (member :sparc-v9 *backend-subfeatures*))
+ (member :sparc-v9 *backend-subfeatures*))
;; V8 has a multiply instruction. This should also work for
;; the V9, but umul and the Y register is deprecated on the
;; V9.
(inst nop)
(inst nop)
(dotimes (i 32)
- (inst mulscc result-high multiplicand))
+ (inst mulscc result-high multiplicand))
(inst mulscc result-high zero-tn)
(inst cmp multiplicand)
(inst b :ge label)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :to (:eval 1))
- (y :scs (unsigned-reg) :to (:eval 1))
- (carry-in :scs (unsigned-reg) :to (:eval 2)))
+ (y :scs (unsigned-reg) :to (:eval 1))
+ (carry-in :scs (unsigned-reg) :to (:eval 2)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:results (hi :scs (unsigned-reg) :from (:eval 0))
- (lo :scs (unsigned-reg) :from (:eval 1)))
+ (lo :scs (unsigned-reg) :from (:eval 1)))
(:result-types unsigned-num unsigned-num)
(:generator 40
(emit-multiply x y hi lo)
(:translate sb!bignum:%multiply-and-add)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :to (:eval 1))
- (y :scs (unsigned-reg) :to (:eval 1))
- (prev :scs (unsigned-reg) :to (:eval 2))
- (carry-in :scs (unsigned-reg) :to (:eval 2)))
+ (y :scs (unsigned-reg) :to (:eval 1))
+ (prev :scs (unsigned-reg) :to (:eval 2))
+ (carry-in :scs (unsigned-reg) :to (:eval 2)))
(:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
(:results (hi :scs (unsigned-reg) :from (:eval 0))
- (lo :scs (unsigned-reg) :from (:eval 1)))
+ (lo :scs (unsigned-reg) :from (:eval 1)))
(:result-types unsigned-num unsigned-num)
(:generator 40
(emit-multiply x y hi lo)
(:translate sb!bignum:%multiply)
(:policy :fast-safe)
(:args (x :scs (unsigned-reg) :to (:result 1))
- (y :scs (unsigned-reg) :to (:result 1)))
+ (y :scs (unsigned-reg) :to (:result 1)))
(:arg-types unsigned-num unsigned-num)
(:results (hi :scs (unsigned-reg))
- (lo :scs (unsigned-reg)))
+ (lo :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:generator 40
(emit-multiply x y hi lo)))
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (div-high :scs (unsigned-reg) :target rem)
- (div-low :scs (unsigned-reg) :target quo)
- (divisor :scs (unsigned-reg)))
+ (div-low :scs (unsigned-reg) :target quo)
+ (divisor :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:results (quo :scs (unsigned-reg) :from (:argument 1))
- (rem :scs (unsigned-reg) :from (:argument 0)))
+ (rem :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num unsigned-num)
(:generator 300
(move rem div-high)
(move quo div-low)
(dotimes (i 33)
(let ((label (gen-label)))
- (inst cmp rem divisor)
- (inst b :ltu label)
- (inst addxcc quo quo)
- (inst sub rem divisor)
- (emit-label label)
- (unless (= i 32)
- (inst addx rem rem))))
+ (inst cmp rem divisor)
+ (inst b :ltu label)
+ (inst addxcc quo quo)
+ (inst sub rem divisor)
+ (emit-label label)
+ (unless (= i 32)
+ (inst addx rem rem))))
(inst not quo)))
(define-vop (bignum-floor-v8)
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (div-high :scs (unsigned-reg) :target rem)
- (div-low :scs (unsigned-reg) :target quo)
- (divisor :scs (unsigned-reg)))
+ (div-low :scs (unsigned-reg) :target quo)
+ (divisor :scs (unsigned-reg)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:results (quo :scs (unsigned-reg) :from (:argument 1))
- (rem :scs (unsigned-reg) :from (:argument 0)))
+ (rem :scs (unsigned-reg) :from (:argument 0)))
(:result-types unsigned-num unsigned-num)
(:temporary (:scs (unsigned-reg) :target quo) q)
;; This vop is for a v8 or v9, provided we're also not using
;; sparc-64, for which there a special sparc-64 vop.
(:guard (or (member :sparc-v8 *backend-subfeatures*)
- (member :sparc-v9 *backend-subfeatures*)))
+ (member :sparc-v9 *backend-subfeatures*)))
(:generator 15
(inst wry div-high)
(inst nop)
(:translate sb!bignum:%floor)
(:policy :fast-safe)
(:args (div-high :scs (unsigned-reg))
- (div-low :scs (unsigned-reg))
- (divisor :scs (unsigned-reg) :to (:result 1)))
+ (div-low :scs (unsigned-reg))
+ (divisor :scs (unsigned-reg) :to (:result 1)))
(:arg-types unsigned-num unsigned-num unsigned-num)
(:temporary (:sc unsigned-reg :from (:argument 0)) dividend)
(:results (quo :scs (unsigned-reg))
- (rem :scs (unsigned-reg)))
+ (rem :scs (unsigned-reg)))
(:result-types unsigned-num unsigned-num)
(:guard (member :sparc-64 *backend-subfeatures*))
(:generator 5
- ;; Set dividend to be div-high and div-low
+ ;; Set dividend to be div-high and div-low
(inst sllx dividend div-high 32)
(inst add dividend div-low)
;; Compute quotient
(:translate sb!bignum:%ashr)
(:policy :fast-safe)
(:args (digit :scs (unsigned-reg))
- (count :scs (unsigned-reg)))
+ (count :scs (unsigned-reg)))
(:arg-types unsigned-num positive-fixnum)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(in-package "SB!C")
(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 shifts and adds"
(let ((y (lvar-value y)))
(multiple-value-bind (result adds shifts)
- (ub32-strength-reduce-constant-multiply 'x y)
+ (ub32-strength-reduce-constant-multiply 'x y)
(cond
;; we assume, perhaps foolishly, that good SPARCs don't have an
;; issue with multiplications. (Remember that there's a
;; different transform for converting x*2^k to a shift).
((member :sparc-64 *backend-subfeatures*) (give-up-ir1-transform))
((or (member :sparc-v9 *backend-subfeatures*)
- (member :sparc-v8 *backend-subfeatures*))
- ;; breakeven point as measured by Raymond Toy
- (when (> (+ adds shifts) 9)
- (give-up-ir1-transform))))
+ (member :sparc-v8 *backend-subfeatures*))
+ ;; breakeven point as measured by Raymond Toy
+ (when (> (+ adds shifts) 9)
+ (give-up-ir1-transform))))
(or result 0))))
(:translate make-array-header)
(:policy :fast-safe)
(:args (type :scs (any-reg))
- (rank :scs (any-reg)))
+ (rank :scs (any-reg)))
(:arg-types tagged-num tagged-num)
(:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
(:temporary (:scs (non-descriptor-reg)) ndescr)
(: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))
(:results (result :scs (any-reg descriptor-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 5
(let ((error (generate-error-code vop invalid-array-index-error
- array bound index)))
+ array bound index)))
(inst cmp index bound)
(inst b :geu error)
(inst nop)
(macrolet ((def-data-vector-frobs (type variant element-type &rest scs)
`(progn
(define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
- ,(symbolicate (string variant) "-REF"))
+ ,(symbolicate (string variant) "-REF"))
(:note "inline array access")
(:variant vector-data-offset other-pointer-lowtag)
(:translate data-vector-ref)
(:results (value :scs ,scs))
(:result-types ,element-type))
(define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
- ,(symbolicate (string variant) "-SET"))
+ ,(symbolicate (string variant) "-SET"))
(:note "inline array store")
(:variant vector-data-offset other-pointer-lowtag)
(:translate data-vector-set)
(:arg-types ,type positive-fixnum ,element-type)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs ,scs))
+ (index :scs (any-reg zero immediate))
+ (value :scs ,scs))
(:results (result :scs ,scs))
(:result-types ,element-type)))))
;;; 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))))
+ (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 (value :scs (any-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
- (:generator 20
- (inst srl temp index ,bit-shift)
- (inst sll temp n-fixnum-tag-bits)
- (inst add temp (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- (inst ld result object temp)
- (inst and temp index ,(1- elements-per-word))
- (inst xor temp ,(1- elements-per-word))
- ,@(unless (= bits 1)
- `((inst sll temp ,(1- (integer-length bits)))))
- (inst srl result temp)
- (inst and result ,(1- (ash 1 bits)))
- (inst sll value result 2)))
+ (: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 (value :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
+ (:generator 20
+ (inst srl temp index ,bit-shift)
+ (inst sll temp n-fixnum-tag-bits)
+ (inst add temp (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst ld result object temp)
+ (inst and temp index ,(1- elements-per-word))
+ (inst xor temp ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst sll temp ,(1- (integer-length bits)))))
+ (inst srl result temp)
+ (inst and result ,(1- (ash 1 bits)))
+ (inst sll value result 2)))
(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)
- (:temporary (:scs (non-descriptor-reg)) temp)
- (:generator 15
- (multiple-value-bind (word extra)
+ (: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)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 15
+ (multiple-value-bind (word extra)
(floor index ,elements-per-word)
- (setf extra (logxor extra (1- ,elements-per-word)))
- (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
- other-pointer-lowtag)))
- (cond ((typep offset '(signed-byte 13))
- (inst ld result object offset))
- (t
- (inst li temp offset)
- (inst ld result object temp))))
- (unless (zerop extra)
- (inst srl result (* extra ,bits)))
- (unless (= extra ,(1- elements-per-word))
- (inst and result ,(1- (ash 1 bits)))))))
+ (setf extra (logxor extra (1- ,elements-per-word)))
+ (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 13))
+ (inst ld result object offset))
+ (t
+ (inst li temp offset)
+ (inst ld result object temp))))
+ (unless (zerop extra)
+ (inst srl 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))
- (index :scs (unsigned-reg) :target shift)
- (value :scs (unsigned-reg zero immediate) :target result))
- (:arg-types ,type positive-fixnum positive-fixnum)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg)) temp old offset)
- (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
- (:generator 25
- (inst srl offset index ,bit-shift)
- (inst sll offset n-fixnum-tag-bits)
- (inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
- (inst ld old object offset)
- (inst and shift index ,(1- elements-per-word))
- (inst xor shift ,(1- elements-per-word))
- ,@(unless (= bits 1)
- `((inst sll shift ,(1- (integer-length bits)))))
- (unless (and (sc-is value immediate)
- (= (tn-value value) ,(1- (ash 1 bits))))
- (inst li temp ,(1- (ash 1 bits)))
- (inst sll temp shift)
- (inst not temp)
- (inst and old temp))
- (unless (sc-is value zero)
- (sc-case value
- (immediate
- (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
- (unsigned-reg
- (inst and temp value ,(1- (ash 1 bits)))))
- (inst sll temp shift)
- (inst or old temp))
- (inst st old object offset)
- (sc-case value
- (immediate
- (inst li result (tn-value value)))
- (t
- (move result value)))))
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg) :target shift)
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type positive-fixnum positive-fixnum)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) temp old offset)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
+ (:generator 25
+ (inst srl offset index ,bit-shift)
+ (inst sll offset n-fixnum-tag-bits)
+ (inst add offset (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
+ (inst ld old object offset)
+ (inst and shift index ,(1- elements-per-word))
+ (inst xor shift ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst sll shift ,(1- (integer-length bits)))))
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (inst li temp ,(1- (ash 1 bits)))
+ (inst sll temp shift)
+ (inst not temp)
+ (inst and old temp))
+ (unless (sc-is value zero)
+ (sc-case value
+ (immediate
+ (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
+ (unsigned-reg
+ (inst and temp value ,(1- (ash 1 bits)))))
+ (inst sll temp shift)
+ (inst or old temp))
+ (inst st old object offset)
+ (sc-case value
+ (immediate
+ (inst li result (tn-value value)))
+ (t
+ (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 zero immediate) :target result))
- (:arg-types ,type
- (:constant index)
- positive-fixnum)
- (:info index)
- (:results (result :scs (unsigned-reg)))
- (:result-types positive-fixnum)
- (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
- (:generator 20
- (multiple-value-bind (word extra) (floor index ,elements-per-word)
- (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
- other-pointer-lowtag)))
- (cond ((typep offset '(signed-byte 13))
- (inst ld old object offset))
- (t
- (inst li offset-reg offset)
- (inst ld old object offset-reg)))
- (unless (and (sc-is value immediate)
- (= (tn-value value) ,(1- (ash 1 bits))))
- (cond ((zerop extra)
- (inst sll old ,bits)
- (inst srl old ,bits))
- (t
- (inst li temp
- (lognot (ash ,(1- (ash 1 bits))
- (* (logxor extra
- ,(1- elements-per-word))
- ,bits))))
- (inst and old temp))))
- (sc-case value
- (zero)
- (immediate
- (let ((value (ash (logand (tn-value value)
- ,(1- (ash 1 bits)))
- (* (logxor extra
- ,(1- elements-per-word))
- ,bits))))
- (cond ((typep value '(signed-byte 13))
- (inst or old value))
- (t
- (inst li temp value)
- (inst or old temp)))))
- (unsigned-reg
- (inst sll temp value
- (* (logxor extra ,(1- elements-per-word)) ,bits))
- (inst or old temp)))
- (if (typep offset '(signed-byte 13))
- (inst st old object offset)
- (inst st old object offset-reg)))
- (sc-case value
- (immediate
- (inst li result (tn-value value)))
- (t
- (move result value))))))))))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type
+ (:constant index)
+ positive-fixnum)
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
+ (cond ((typep offset '(signed-byte 13))
+ (inst ld old object offset))
+ (t
+ (inst li offset-reg offset)
+ (inst ld old object offset-reg)))
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (cond ((zerop extra)
+ (inst sll old ,bits)
+ (inst srl old ,bits))
+ (t
+ (inst li temp
+ (lognot (ash ,(1- (ash 1 bits))
+ (* (logxor extra
+ ,(1- elements-per-word))
+ ,bits))))
+ (inst and old temp))))
+ (sc-case value
+ (zero)
+ (immediate
+ (let ((value (ash (logand (tn-value value)
+ ,(1- (ash 1 bits)))
+ (* (logxor extra
+ ,(1- elements-per-word))
+ ,bits))))
+ (cond ((typep value '(signed-byte 13))
+ (inst or old value))
+ (t
+ (inst li temp value)
+ (inst or old temp)))))
+ (unsigned-reg
+ (inst sll temp value
+ (* (logxor extra ,(1- elements-per-word)) ,bits))
+ (inst or old temp)))
+ (if (typep offset '(signed-byte 13))
+ (inst st old object offset)
+ (inst st old object offset-reg)))
+ (sc-case value
+ (immediate
+ (inst li result (tn-value value)))
+ (t
+ (move result value))))))))))
(def-small-data-vector-frobs simple-bit-vector 1)
(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
(: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)))
(:temporary (:scs (non-descriptor-reg)) offset)
(:result-types single-float)
(:generator 5
(inst add offset index (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst ldf value object offset)))
(: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)
(:temporary (:scs (non-descriptor-reg)) offset)
(:generator 5
(inst add offset index
- (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ (- (* vector-data-offset n-word-bytes)
+ other-pointer-lowtag))
(inst stf value object offset)
(unless (location= result value)
(inst fmovs 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 sll offset index 1)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst lddf value object offset)))
(define-vop (data-vector-set/simple-array-double-float)
(: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 sll offset index 1)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst stdf value object offset)
(unless (location= result value)
(move-double-reg 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-long-float positive-fixnum)
(:results (value :scs (long-reg)))
(:result-types long-float)
(:generator 7
(inst sll offset index 2)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(load-long-reg value object offset nil)))
#!+long-float
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
- (value :scs (long-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (long-reg) :target result))
(:arg-types simple-array-long-float positive-fixnum long-float)
(:results (result :scs (long-reg)))
(:result-types long-float)
(:generator 20
(inst sll offset index 2)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(store-long-reg value object offset nil)
(unless (location= result value)
(move-long-reg result value))))
(:translate data-vector-set)
(:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs (signed-reg)))
+ (index :scs (any-reg zero immediate))
+ (value :scs (signed-reg)))
(:results (result :scs (signed-reg)))
(:result-types tagged-num))
(define-vop (data-vector-ref/simple-array-signed-byte-16
- signed-halfword-index-ref)
+ signed-halfword-index-ref)
(:note "inline array access")
(:variant vector-data-offset other-pointer-lowtag)
(:translate data-vector-ref)
(:translate data-vector-set)
(:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs (signed-reg)))
+ (index :scs (any-reg zero immediate))
+ (value :scs (signed-reg)))
(:results (result :scs (signed-reg)))
(:result-types tagged-num))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-complex-single-float positive-fixnum)
(:results (value :scs (complex-single-reg)))
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(let ((real-tn (complex-single-reg-real-tn value)))
(inst sll offset index 1)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst ldf real-tn object offset))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(inst add offset n-word-bytes)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (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)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(: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 sll offset index 1)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst stf value-real object offset)
(unless (location= result-real value-real)
- (inst fmovs result-real value-real)))
+ (inst fmovs 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 add offset n-word-bytes)
(inst stf value-imag object offset)
(unless (location= result-imag value-imag)
- (inst fmovs result-imag value-imag)))))
+ (inst fmovs 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) :to :result)
- (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)
(let ((real-tn (complex-double-reg-real-tn value)))
(inst sll offset index 2)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst lddf real-tn object offset))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(inst add offset (* 2 n-word-bytes))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (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)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(: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 sll offset index 2)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(inst stdf value-real object offset)
(unless (location= result-real value-real)
- (move-double-reg result-real value-real)))
+ (move-double-reg 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 add offset (* 2 n-word-bytes))
(inst stdf value-imag object offset)
(unless (location= result-imag value-imag)
- (move-double-reg result-imag value-imag)))))
+ (move-double-reg result-imag value-imag)))))
#!+long-float
(define-vop (data-vector-ref/simple-array-complex-long-float)
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types simple-array-complex-long-float positive-fixnum)
(:results (value :scs (complex-long-reg)))
(:result-types complex-long-float)
(let ((real-tn (complex-long-reg-real-tn value)))
(inst sll offset index 3)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(load-long-reg real-tn object offset nil))
(let ((imag-tn (complex-long-reg-imag-tn value)))
(inst add offset (* 4 n-word-bytes))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to :result)
- (index :scs (any-reg))
- (value :scs (complex-long-reg) :target result))
+ (index :scs (any-reg))
+ (value :scs (complex-long-reg) :target result))
(:arg-types simple-array-complex-long-float positive-fixnum
- complex-long-float)
+ complex-long-float)
(:results (result :scs (complex-long-reg)))
(:result-types complex-long-float)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
(:generator 20
(let ((value-real (complex-long-reg-real-tn value))
- (result-real (complex-long-reg-real-tn result)))
+ (result-real (complex-long-reg-real-tn result)))
(inst sll offset index 3)
(inst add offset (- (* vector-data-offset n-word-bytes)
- other-pointer-lowtag))
+ other-pointer-lowtag))
(store-long-reg value-real object offset nil)
(unless (location= result-real value-real)
- (move-long-reg result-real value-real)))
+ (move-long-reg result-real value-real)))
(let ((value-imag (complex-long-reg-imag-tn value))
- (result-imag (complex-long-reg-imag-tn result)))
+ (result-imag (complex-long-reg-imag-tn result)))
(inst add offset (* 4 n-word-bytes))
(store-long-reg value-imag object offset nil)
(unless (location= result-imag value-imag)
- (move-long-reg result-imag value-imag)))))
+ (move-long-reg result-imag value-imag)))))
\f
;;; These VOPs are used for implementing float slots in structures (whose raw
(:translate %raw-set-long)
(:arg-types sb!c::raw-vector positive-fixnum long-float))
(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-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-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-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))
#!+long-float
(define-vop (raw-ref-complex-long
- data-vector-ref/simple-array-complex-long-float)
+ data-vector-ref/simple-array-complex-long-float)
(:translate %raw-ref-complex-long)
(:arg-types sb!c::raw-vector positive-fixnum))
#!+long-float
(define-vop (raw-set-complex-long
- data-vector-set/simple-array-complex-long-float)
+ data-vector-set/simple-array-complex-long-float)
(:translate %raw-set-complex-long)
(:arg-types sb!c::raw-vector positive-fixnum complex-long-float))
(:note "setf raw-bits VOP")
(:translate %set-raw-bits)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs (unsigned-reg)))
+ (index :scs (any-reg zero immediate))
+ (value :scs (unsigned-reg)))
(:arg-types * tagged-num unsigned-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:note "setf vector-raw-bits VOP")
(:translate %set-vector-raw-bits)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- (value :scs (unsigned-reg)))
+ (index :scs (any-reg zero immediate))
+ (value :scs (unsigned-reg)))
(:arg-types * tagged-num unsigned-num)
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(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
(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 (+ reg-args nl0-offset)))
- (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 16)))))))
+ (setf (arg-state-register-args state) (1+ reg-args))
+ (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
+ (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 16)))))))
(define-alien-type-method (integer :arg-tn) (type state)
(if (alien-integer-type-signed 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-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)
(declare (ignore type))
(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 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)
(declare (type alien-fun-type 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 nsp-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))
(aver (sb!c::constant-lvar-p type))
(let* ((type (sb!c::lvar-value type))
- (arg-types (alien-fun-type-arg-types type))
- (result-type (alien-fun-type-result-type type)))
+ (arg-types (alien-fun-type-arg-types type))
+ (result-type (alien-fun-type-result-type type)))
(aver (= (length arg-types) (length args)))
;; We need to do something special for the following argument
;; types: single-float, double-float, and 64-bit integers. For
;; results, we need something special for 64-bit integer results.
(if (or (some #'alien-single-float-type-p arg-types)
- (some #'alien-double-float-type-p arg-types)
- (some #'(lambda (type)
- (and (alien-integer-type-p type)
- (> (sb!alien::alien-integer-type-bits type) 32)))
- arg-types)
- #!+long-float (some #'alien-long-float-type-p arg-types)
- (and (alien-integer-type-p result-type)
- (> (sb!alien::alien-integer-type-bits result-type) 32)))
- (collect ((new-args) (lambda-vars) (new-arg-types))
- (dolist (type arg-types)
- (let ((arg (gensym)))
- (lambda-vars arg)
- (cond ((and (alien-integer-type-p type)
- (> (sb!alien::alien-integer-type-bits type) 32))
- ;; 64-bit long long types are stored in
- ;; consecutive locations, most significant word
- ;; first (big-endian).
- (new-args `(ash ,arg -32))
- (new-args `(logand ,arg #xffffffff))
- (if (alien-integer-type-signed type)
- (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- ((alien-single-float-type-p type)
- (new-args `(single-float-bits ,arg))
- (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv))))
- ((alien-double-float-type-p type)
- (new-args `(double-float-high-bits ,arg))
- (new-args `(double-float-low-bits ,arg))
- (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- #!+long-float
- ((alien-long-float-type-p type)
- (new-args `(long-float-exp-bits ,arg))
- (new-args `(long-float-high-bits ,arg))
- (new-args `(long-float-mid-bits ,arg))
- (new-args `(long-float-low-bits ,arg))
- (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
- (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
- (t
- (new-args arg)
- (new-arg-types type)))))
- (cond ((and (alien-integer-type-p result-type)
- (> (sb!alien::alien-integer-type-bits result-type) 32))
- (let ((new-result-type
- (let ((sb!alien::*values-type-okay* t))
- (parse-alien-type
- (if (alien-integer-type-signed result-type)
- '(values (signed 32) (unsigned 32))
- '(values (unsigned 32) (unsigned 32)))
- (sb!kernel:make-null-lexenv)))))
- `(lambda (function type ,@(lambda-vars))
- (declare (ignore type))
- (multiple-value-bind (high low)
- (%alien-funcall function
- ',(make-alien-fun-type
- :arg-types (new-arg-types)
- :result-type new-result-type)
- ,@(new-args))
- (logior low (ash high 32))))))
- (t
- `(lambda (function type ,@(lambda-vars))
- (declare (ignore type))
- (%alien-funcall function
- ',(make-alien-fun-type
- :arg-types (new-arg-types)
- :result-type result-type)
- ,@(new-args))))))
- (sb!c::give-up-ir1-transform))))
+ (some #'alien-double-float-type-p arg-types)
+ (some #'(lambda (type)
+ (and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32)))
+ arg-types)
+ #!+long-float (some #'alien-long-float-type-p arg-types)
+ (and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32)))
+ (collect ((new-args) (lambda-vars) (new-arg-types))
+ (dolist (type arg-types)
+ (let ((arg (gensym)))
+ (lambda-vars arg)
+ (cond ((and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32))
+ ;; 64-bit long long types are stored in
+ ;; consecutive locations, most significant word
+ ;; first (big-endian).
+ (new-args `(ash ,arg -32))
+ (new-args `(logand ,arg #xffffffff))
+ (if (alien-integer-type-signed type)
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ ((alien-single-float-type-p type)
+ (new-args `(single-float-bits ,arg))
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv))))
+ ((alien-double-float-type-p type)
+ (new-args `(double-float-high-bits ,arg))
+ (new-args `(double-float-low-bits ,arg))
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ #!+long-float
+ ((alien-long-float-type-p type)
+ (new-args `(long-float-exp-bits ,arg))
+ (new-args `(long-float-high-bits ,arg))
+ (new-args `(long-float-mid-bits ,arg))
+ (new-args `(long-float-low-bits ,arg))
+ (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv)))
+ (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
+ (t
+ (new-args arg)
+ (new-arg-types type)))))
+ (cond ((and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32))
+ (let ((new-result-type
+ (let ((sb!alien::*values-type-okay* t))
+ (parse-alien-type
+ (if (alien-integer-type-signed result-type)
+ '(values (signed 32) (unsigned 32))
+ '(values (unsigned 32) (unsigned 32)))
+ (sb!kernel:make-null-lexenv)))))
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (multiple-value-bind (high low)
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type new-result-type)
+ ,@(new-args))
+ (logior low (ash high 32))))))
+ (t
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (%alien-funcall function
+ ',(make-alien-fun-type
+ :arg-types (new-arg-types)
+ :result-type result-type)
+ ,@(new-args))))))
+ (sb!c::give-up-ir1-transform))))
(define-vop (foreign-symbol-sap)
(:translate foreign-symbol-sap)
(define-vop (call-out)
(:args (function :scs (sap-reg) :target cfunc)
- (args :more t))
+ (args :more t))
(:results (results :more t))
(:ignore args results)
(:save-p t)
(:temporary (:sc any-reg :offset cfunc-offset
- :from (:argument 0) :to (:result 0)) cfunc)
+ :from (:argument 0) :to (:result 0)) cfunc)
(:temporary (:sc interior-reg :offset lip-offset) lip)
(:temporary (:scs (any-reg) :to (:result 0)) temp)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:generator 0
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(move cfunc function)
(inst li temp (make-fixup "call_into_c" :foreign))
(inst jal lip temp)
(inst nop)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))))
+ (load-stack-tn cur-nfp nfp-save)))))
(define-vop (alloc-number-stack-space)
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (cond ((< delta (ash 1 12))
- (inst sub nsp-tn delta))
- (t
- (inst li temp delta)
- (inst sub nsp-tn temp)))))
+ (cond ((< delta (ash 1 12))
+ (inst sub nsp-tn delta))
+ (t
+ (inst li temp delta)
+ (inst sub nsp-tn temp)))))
(unless (location= result nsp-tn)
;; They are only location= when the result tn was allocated by
;; make-call-out-tns above, which takes the number-stack-displacement
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (cond ((< delta (ash 1 12))
- (inst add nsp-tn delta))
- (t
- (inst li temp delta)
- (inst add nsp-tn temp)))))))
+ (cond ((< delta (ash 1 12))
+ (inst add nsp-tn delta))
+ (t
+ (inst li temp delta)
+ (inst add nsp-tn temp)))))))
(declare (type unsigned-byte n))
(if (< n register-arg-count)
(make-wired-tn *backend-t-primitive-type* register-arg-scn
- (elt *register-arg-offsets* n))
+ (elt *register-arg-offsets* n))
(make-wired-tn *backend-t-primitive-type* control-stack-arg-scn n)))
(specify-save-tn
(physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
(make-wired-tn *fixnum-primitive-type*
- control-stack-arg-scn
- ocfp-save-offset)))
+ control-stack-arg-scn
+ ocfp-save-offset)))
(!def-vm-support-routine make-return-pc-save-location (env)
(specify-save-tn
(physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env)
(make-wired-tn *backend-t-primitive-type*
- control-stack-arg-scn
- lra-save-offset)))
+ control-stack-arg-scn
+ lra-save-offset)))
;;; Make a TN for the standard argument count passing location. We
;;; only need to make the standard location, since a count is never
;;; unknown-values 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
(declare (type component component))
(dotimes (i code-constants-offset)
(vector-push-extend nil
- (ir2-component-constants (component-info component))))
+ (ir2-component-constants (component-info component))))
(values))
\f
;;;; Frame hackery:
(:generator 1
(let ((nfp (current-nfp-tn vop)))
(when nfp
- (inst add val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
+ (inst add val nfp (bytes-needed-for-non-descriptor-stack-frame))))))
(define-vop (xep-allocate-frame)
(inst compute-code-from-fn code-tn code-tn start-lab temp)
;; Build our stack frames.
(inst add csp-tn cfp-tn
- (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
(let ((nfp-tn (current-nfp-tn vop)))
(when nfp-tn
- (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame))
- (inst add nfp-tn nsp-tn number-stack-displacement)))
+ (inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame))
+ (inst add nfp-tn nsp-tn number-stack-displacement)))
(trace-table-entry trace-table-normal)))
(define-vop (allocate-frame)
(:results (res :scs (any-reg))
- (nfp :scs (any-reg)))
+ (nfp :scs (any-reg)))
(:info callee)
(:generator 2
(trace-table-entry trace-table-fun-prologue)
(move res csp-tn)
(inst add csp-tn csp-tn
- (* n-word-bytes (sb-allocated-size 'control-stack)))
+ (* n-word-bytes (sb-allocated-size 'control-stack)))
(when (ir2-physenv-number-stack-p callee)
(inst sub nsp-tn (bytes-needed-for-non-descriptor-stack-frame))
(inst add nfp nsp-tn number-stack-displacement))
;;;
;;; The general-case code looks like this:
#|
- b regs-defaulted ; Skip if MVs
- nop
+ b regs-defaulted ; Skip if MVs
+ nop
- move a1 null-tn ; Default register values
- ...
- loadi nargs 1 ; Force defaulting of stack values
- move old-fp csp ; Set up args for SP resetting
+ move a1 null-tn ; Default register values
+ ...
+ loadi nargs 1 ; Force defaulting of stack values
+ move old-fp csp ; Set up args for SP resetting
regs-defaulted
- subcc temp nargs register-arg-count
+ subcc temp nargs register-arg-count
- b :lt default-value-7 ; jump to default code
- loadw move-temp ocfp-tn 6 ; Move value to correct location.
+ b :lt default-value-7 ; jump to default code
+ loadw move-temp ocfp-tn 6 ; Move value to correct location.
subcc temp 1
- store-stack-tn val4-tn move-temp
+ store-stack-tn val4-tn move-temp
- b :lt default-value-8
- loadw move-temp ocfp-tn 7
+ b :lt default-value-8
+ loadw move-temp ocfp-tn 7
subcc temp 1
- store-stack-tn val5-tn move-temp
+ store-stack-tn val5-tn move-temp
- ...
+ ...
defaulting-done
- move csp ocfp ; Reset SP.
+ move csp ocfp ; Reset SP.
<end of code>
<elsewhere>
default-value-7
- store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack)
+ store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack)
default-value-8
- store-stack-tn val5-tn null-tn ; Nil out 8'th value.
+ store-stack-tn val5-tn null-tn ; Nil out 8'th value.
- ...
+ ...
- br defaulting-done
+ br defaulting-done
nop
|#
(defun default-unknown-values (vop values nvals move-temp temp lra-label)
(declare (type (or tn-ref null) values)
- (type unsigned-byte nvals) (type tn move-temp temp))
+ (type unsigned-byte nvals) (type tn move-temp temp))
(if (<= nvals 1)
(progn
- (without-scheduling ()
- (note-this-location vop :single-value-return)
- (move csp-tn ocfp-tn)
- (inst nop))
- (inst compute-code-from-lra code-tn code-tn lra-label temp))
+ (without-scheduling ()
+ (note-this-location vop :single-value-return)
+ (move csp-tn ocfp-tn)
+ (inst nop))
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))
(let ((regs-defaulted (gen-label))
- (defaulting-done (gen-label))
- (default-stack-vals (gen-label)))
- ;; Branch off to the MV case.
- (without-scheduling ()
- (note-this-location vop :unknown-return)
- (inst b regs-defaulted)
- (if (> nvals register-arg-count)
- (inst subcc temp nargs-tn (fixnumize register-arg-count))
- (move csp-tn ocfp-tn)))
-
- ;; Do the single value calse.
- (do ((i 1 (1+ i))
- (val (tn-ref-across values) (tn-ref-across val)))
- ((= i (min nvals register-arg-count)))
- (move (tn-ref-tn val) null-tn))
- (when (> nvals register-arg-count)
- (inst b default-stack-vals)
- (move ocfp-tn csp-tn))
-
- (emit-label regs-defaulted)
- (when (> nvals register-arg-count)
- (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 b :le default-lab)
- (inst ld move-temp ocfp-tn (* i n-word-bytes))
- (inst subcc temp (fixnumize 1))
- (store-stack-tn tn move-temp)))
-
- (emit-label defaulting-done)
- (move csp-tn ocfp-tn)
-
- (let ((defaults (defaults)))
- (when defaults
- (assemble (*elsewhere*)
- (emit-label default-stack-vals)
- (trace-table-entry trace-table-fun-prologue)
- (do ((remaining defaults (cdr remaining)))
- ((null remaining))
- (let ((def (car remaining)))
- (emit-label (car def))
- (when (null (cdr remaining))
- (inst b defaulting-done))
- (store-stack-tn (cdr def) null-tn)))
- (trace-table-entry trace-table-normal))))))
-
- (inst compute-code-from-lra code-tn code-tn lra-label temp)))
+ (defaulting-done (gen-label))
+ (default-stack-vals (gen-label)))
+ ;; Branch off to the MV case.
+ (without-scheduling ()
+ (note-this-location vop :unknown-return)
+ (inst b regs-defaulted)
+ (if (> nvals register-arg-count)
+ (inst subcc temp nargs-tn (fixnumize register-arg-count))
+ (move csp-tn ocfp-tn)))
+
+ ;; Do the single value calse.
+ (do ((i 1 (1+ i))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i (min nvals register-arg-count)))
+ (move (tn-ref-tn val) null-tn))
+ (when (> nvals register-arg-count)
+ (inst b default-stack-vals)
+ (move ocfp-tn csp-tn))
+
+ (emit-label regs-defaulted)
+ (when (> nvals register-arg-count)
+ (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 b :le default-lab)
+ (inst ld move-temp ocfp-tn (* i n-word-bytes))
+ (inst subcc temp (fixnumize 1))
+ (store-stack-tn tn move-temp)))
+
+ (emit-label defaulting-done)
+ (move csp-tn ocfp-tn)
+
+ (let ((defaults (defaults)))
+ (when defaults
+ (assemble (*elsewhere*)
+ (emit-label default-stack-vals)
+ (trace-table-entry trace-table-fun-prologue)
+ (do ((remaining defaults (cdr remaining)))
+ ((null remaining))
+ (let ((def (car remaining)))
+ (emit-label (car def))
+ (when (null (cdr remaining))
+ (inst b defaulting-done))
+ (store-stack-tn (cdr def) null-tn)))
+ (trace-table-entry trace-table-normal))))))
+
+ (inst compute-code-from-lra code-tn code-tn lra-label temp)))
(values))
\f
(defun receive-unknown-values (args nargs start count lra-label temp)
(declare (type tn args nargs start count temp))
(let ((variable-values (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(without-scheduling ()
(inst b variable-values)
(inst nop))
-
+
(inst compute-code-from-lra code-tn code-tn lra-label temp)
(inst add csp-tn 4)
(storew (first *register-arg-tns*) csp-tn -1)
(inst sub start csp-tn 4)
(inst li count (fixnumize 1))
-
+
(emit-label done)
-
+
(assemble (*elsewhere*)
(trace-table-entry trace-table-fun-prologue)
(emit-label variable-values)
(inst compute-code-from-lra code-tn code-tn lra-label temp)
(do ((arg *register-arg-tns* (rest arg))
- (i 0 (1+ i)))
- ((null arg))
- (storew (first arg) args i))
+ (i 0 (1+ i)))
+ ((null arg))
+ (storew (first arg) args i))
(move start args)
(move count nargs)
(inst b done)
(start :scs (any-reg))
(count :scs (any-reg)))
(:temporary (:sc descriptor-reg :offset ocfp-offset
- :from :eval :to (:result 0))
- values-start)
+ :from :eval :to (:result 0))
+ values-start)
(:temporary (:sc any-reg :offset nargs-offset
- :from :eval :to (:result 1))
- nvals)
+ :from :eval :to (:result 1))
+ nvals)
(:temporary (:scs (non-descriptor-reg)) temp))
;;; MAYBE-LOAD-STACK-TN.
(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)
(:generator 5
(trace-table-entry trace-table-call-site)
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(inst nop)
(emit-return-pc label)
(default-unknown-values vop values nvals move-temp temp label)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))
+ (load-stack-tn cur-nfp nfp-save)))
(trace-table-entry trace-table-normal)))
;;; MAYBE-LOAD-STACK-TN.
(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)
(:generator 20
(trace-table-entry trace-table-call-site)
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(inst nop)
(note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count label temp)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))
+ (load-stack-tn cur-nfp nfp-save)))
(trace-table-entry trace-table-normal)))
\f
;;; 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)
(:generator 5
(trace-table-entry trace-table-call-site)
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (when callee-nfp
- (maybe-load-stack-tn callee-nfp nfp)))
+ (when callee-nfp
+ (maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(inst nop)
(emit-return-pc label)
(note-this-location vop :known-return)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save)))
+ (load-stack-tn cur-nfp nfp-save)))
(trace-table-entry trace-table-normal)))
;;; Return from known values call. We receive the return locations as
;;; MAYBE-LOAD-STACK-TN.
(define-vop (known-return)
(:args (old-fp :target old-fp-temp)
- (return-pc :target return-pc-temp)
- (vals :more t))
+ (return-pc :target return-pc-temp)
+ (vals :more t))
(:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
(:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
(:move-args :known-return)
(move csp-tn cfp-tn)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst add nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (inst add nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
(inst j return-pc-temp (- n-word-bytes other-pointer-lowtag))
(move cfp-tn old-fp-temp)
(trace-table-entry trace-table-normal)))
;;; replication in defining the cross-product VOPs.
;;;
;;; Name is the name of the VOP to define.
-;;;
+;;;
;;; Named is true if the first argument is a symbol whose global function
;;; definition is to be called.
;;;
(defmacro define-full-call (name named return variable)
(aver (not (and variable (eq return :tail))))
`(define-vop (,name
- ,@(when (eq return :unknown)
- '(unknown-values-receiver)))
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
(:args
,@(unless (eq return :tail)
- '((new-fp :scs (any-reg) :to :eval)))
+ '((new-fp :scs (any-reg) :to :eval)))
,(if named
- '(name :target name-pass)
- '(arg-fun :target lexenv))
-
+ '(name :target name-pass)
+ '(arg-fun :target lexenv))
+
,@(when (eq return :tail)
- '((old-fp :target old-fp-pass)
- (return-pc :target return-pc-pass)))
-
+ '((old-fp :target old-fp-pass)
+ (return-pc :target return-pc-pass)))
+
,@(unless variable '((args :more t :scs (descriptor-reg)))))
,@(when (eq return :fixed)
- '((:results (values :more t))))
-
+ '((:results (values :more t))))
+
(:save-p ,(if (eq return :tail) :compute-only t))
,@(unless (or (eq return :tail) variable)
- '((:move-args :full-call)))
+ '((:move-args :full-call)))
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(unless variable '(nargs))
+ ,@(when (eq return :fixed) '(nvals)))
(:ignore
,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(args)))
(:temporary (:sc descriptor-reg
- :offset ocfp-offset
- :from (:argument 1)
- ,@(unless (eq return :fixed)
- '(:to :eval)))
- old-fp-pass)
+ :offset ocfp-offset
+ :from (:argument 1)
+ ,@(unless (eq return :fixed)
+ '(:to :eval)))
+ old-fp-pass)
(:temporary (:sc descriptor-reg
- :offset lra-offset
- :from (:argument ,(if (eq return :tail) 2 1))
- :to :eval)
- return-pc-pass)
+ :offset lra-offset
+ :from (:argument ,(if (eq return :tail) 2 1))
+ :to :eval)
+ return-pc-pass)
,(if named
- `(:temporary (:sc descriptor-reg :offset cname-offset
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- name-pass)
- `(:temporary (:sc descriptor-reg :offset lexenv-offset
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- lexenv))
+ `(:temporary (:sc descriptor-reg :offset cname-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ name-pass)
+ `(:temporary (:sc descriptor-reg :offset lexenv-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ lexenv))
(:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
- function)
+ function)
(:temporary (:sc any-reg :offset nargs-offset :to :eval)
- nargs-pass)
+ nargs-pass)
,@(when variable
- (mapcar #'(lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :to :eval)
- ,name))
- register-arg-names *register-arg-offsets*))
+ (mapcar #'(lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :to :eval)
+ ,name))
+ register-arg-names *register-arg-offsets*))
,@(when (eq return :fixed)
- '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+ '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
,@(unless (eq return :tail)
- '((:temporary (:scs (non-descriptor-reg)) temp)
- (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+ '((:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
(:generator ,(+ (if named 5 0)
- (if variable 19 1)
- (if (eq return :tail) 0 10)
- 15
- (if (eq return :unknown) 25 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)
(let* ((cur-nfp (current-nfp-tn vop))
- ,@(unless (eq return :tail)
- '((lra-label (gen-label))))
- (filler
- (remove nil
- (list :load-nargs
- ,@(if (eq return :tail)
- '((unless (location= old-fp old-fp-pass)
- :load-old-fp)
- (unless (location= return-pc
- return-pc-pass)
- :load-return-pc)
- (when cur-nfp
- :frob-nfp))
- '(:comp-lra
- (when cur-nfp
- :frob-nfp)
- :save-fp
- :load-fp))))))
- (flet ((do-next-filler ()
- (let* ((next (pop filler))
- (what (if (consp next) (car next) next)))
- (ecase what
- (:load-nargs
- ,@(if variable
- `((inst sub nargs-pass csp-tn new-fp)
- ,@(let ((index -1))
- (mapcar #'(lambda (name)
- `(loadw ,name new-fp
- ,(incf index)))
- register-arg-names)))
- '((inst li nargs-pass (fixnumize nargs)))))
- ,@(if (eq return :tail)
- '((:load-old-fp
- (sc-case old-fp
- (any-reg
- (inst move old-fp-pass old-fp))
- (control-stack
- (loadw old-fp-pass cfp-tn
- (tn-offset old-fp)))))
- (:load-return-pc
- (sc-case return-pc
- (descriptor-reg
- (inst move return-pc-pass return-pc))
- (control-stack
- (loadw return-pc-pass cfp-tn
- (tn-offset return-pc)))))
- (:frob-nfp
- (inst add nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
- `((:comp-lra
- (inst compute-lra-from-code
- return-pc-pass code-tn lra-label temp))
- (:frob-nfp
- (store-stack-tn nfp-save cur-nfp))
- (:save-fp
- (inst move old-fp-pass cfp-tn))
- (:load-fp
- ,(if variable
- '(move cfp-tn new-fp)
- '(if (> nargs register-arg-count)
- (move cfp-tn new-fp)
- (move cfp-tn csp-tn))))))
- ((nil))))))
-
- ,@(if named
- `((sc-case name
- (descriptor-reg (move name-pass name))
- (control-stack
- (loadw name-pass cfp-tn (tn-offset name))
- (do-next-filler))
- (constant
- (loadw name-pass code-tn (tn-offset name)
- other-pointer-lowtag)
- (do-next-filler)))
- (loadw function name-pass fdefn-raw-addr-slot
- other-pointer-lowtag)
- (do-next-filler))
- `((sc-case arg-fun
- (descriptor-reg (move lexenv arg-fun))
- (control-stack
- (loadw lexenv cfp-tn (tn-offset arg-fun))
- (do-next-filler))
- (constant
- (loadw lexenv code-tn (tn-offset arg-fun)
- other-pointer-lowtag)
- (do-next-filler)))
- (loadw function lexenv closure-fun-slot
- fun-pointer-lowtag)
- (do-next-filler)))
- (loop
- (if filler
- (do-next-filler)
- (return)))
-
- (note-this-location vop :call-site)
- (inst j function
- (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag))
- (inst move code-tn function))
-
- ,@(ecase return
- (:fixed
- '((emit-return-pc lra-label)
- (default-unknown-values vop values nvals move-temp
- temp lra-label)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:unknown
- '((emit-return-pc lra-label)
- (note-this-location vop :unknown-return)
- (receive-unknown-values values-start nvals start count
- lra-label temp)
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))))
- (:tail)))
+ ,@(unless (eq return :tail)
+ '((lra-label (gen-label))))
+ (filler
+ (remove nil
+ (list :load-nargs
+ ,@(if (eq return :tail)
+ '((unless (location= old-fp old-fp-pass)
+ :load-old-fp)
+ (unless (location= return-pc
+ return-pc-pass)
+ :load-return-pc)
+ (when cur-nfp
+ :frob-nfp))
+ '(:comp-lra
+ (when cur-nfp
+ :frob-nfp)
+ :save-fp
+ :load-fp))))))
+ (flet ((do-next-filler ()
+ (let* ((next (pop filler))
+ (what (if (consp next) (car next) next)))
+ (ecase what
+ (:load-nargs
+ ,@(if variable
+ `((inst sub nargs-pass csp-tn new-fp)
+ ,@(let ((index -1))
+ (mapcar #'(lambda (name)
+ `(loadw ,name new-fp
+ ,(incf index)))
+ register-arg-names)))
+ '((inst li nargs-pass (fixnumize nargs)))))
+ ,@(if (eq return :tail)
+ '((:load-old-fp
+ (sc-case old-fp
+ (any-reg
+ (inst move old-fp-pass old-fp))
+ (control-stack
+ (loadw old-fp-pass cfp-tn
+ (tn-offset old-fp)))))
+ (:load-return-pc
+ (sc-case return-pc
+ (descriptor-reg
+ (inst move return-pc-pass return-pc))
+ (control-stack
+ (loadw return-pc-pass cfp-tn
+ (tn-offset return-pc)))))
+ (:frob-nfp
+ (inst add nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
+ `((:comp-lra
+ (inst compute-lra-from-code
+ return-pc-pass code-tn lra-label temp))
+ (:frob-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (:save-fp
+ (inst move old-fp-pass cfp-tn))
+ (:load-fp
+ ,(if variable
+ '(move cfp-tn new-fp)
+ '(if (> nargs register-arg-count)
+ (move cfp-tn new-fp)
+ (move cfp-tn csp-tn))))))
+ ((nil))))))
+
+ ,@(if named
+ `((sc-case name
+ (descriptor-reg (move name-pass name))
+ (control-stack
+ (loadw name-pass cfp-tn (tn-offset name))
+ (do-next-filler))
+ (constant
+ (loadw name-pass code-tn (tn-offset name)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw function name-pass fdefn-raw-addr-slot
+ other-pointer-lowtag)
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move lexenv arg-fun))
+ (control-stack
+ (loadw lexenv cfp-tn (tn-offset arg-fun))
+ (do-next-filler))
+ (constant
+ (loadw lexenv code-tn (tn-offset arg-fun)
+ other-pointer-lowtag)
+ (do-next-filler)))
+ (loadw function lexenv closure-fun-slot
+ fun-pointer-lowtag)
+ (do-next-filler)))
+ (loop
+ (if filler
+ (do-next-filler)
+ (return)))
+
+ (note-this-location vop :call-site)
+ (inst j function
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))
+ (inst move code-tn function))
+
+ ,@(ecase return
+ (:fixed
+ '((emit-return-pc lra-label)
+ (default-unknown-values vop values nvals move-temp
+ temp lra-label)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:unknown
+ '((emit-return-pc lra-label)
+ (note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count
+ lra-label temp)
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))))
+ (:tail)))
(trace-table-entry trace-table-normal))))
;; Clear the number stack if anything is there.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst add nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (inst add nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
;; And jump to the assembly-routine that does the bliting.
(inst ji temp (make-fixup 'tail-call-variable :assembly-routine))
;;; Return a single value using the unknown-values convention.
(define-vop (return-single)
(:args (old-fp :scs (any-reg))
- (return-pc :scs (descriptor-reg))
- (value))
+ (return-pc :scs (descriptor-reg))
+ (value))
(:ignore value)
(:vop-var vop)
(:generator 6
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst add nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (inst add nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
;; Clear the control stack, and restore the frame pointer.
(move csp-tn cfp-tn)
(move cfp-tn old-fp)
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst add nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (inst add nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
(cond ((= nvals 1)
- ;; Clear the control stack, and restore the frame pointer.
- (move csp-tn cfp-tn)
- (move cfp-tn old-fp)
- ;; Out of here.
- (lisp-return return-pc :offset 2))
- (t
- ;; Establish the values pointer and values count.
- (move val-ptr cfp-tn)
- (inst li nargs (fixnumize nvals))
- ;; restore the frame pointer and clear as much of the control
- ;; stack as possible.
- (move cfp-tn old-fp)
- (inst add csp-tn val-ptr (* nvals n-word-bytes))
- ;; pre-default any argument register that need it.
- (when (< nvals register-arg-count)
- (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
- (move reg null-tn)))
- ;; And away we go.
- (lisp-return return-pc)))
+ ;; Clear the control stack, and restore the frame pointer.
+ (move csp-tn cfp-tn)
+ (move cfp-tn old-fp)
+ ;; Out of here.
+ (lisp-return return-pc :offset 2))
+ (t
+ ;; Establish the values pointer and values count.
+ (move val-ptr cfp-tn)
+ (inst li nargs (fixnumize nvals))
+ ;; restore the frame pointer and clear as much of the control
+ ;; stack as possible.
+ (move cfp-tn old-fp)
+ (inst add csp-tn val-ptr (* nvals n-word-bytes))
+ ;; pre-default any argument register that need it.
+ (when (< nvals register-arg-count)
+ (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
+ (move reg null-tn)))
+ ;; And away we go.
+ (lisp-return return-pc)))
(trace-table-entry trace-table-normal)))
;;; Do unknown-values return of an arbitrary number of values (passed on the
(let ((not-single (gen-label)))
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
- (when cur-nfp
- (inst add nsp-tn cur-nfp
- (- (bytes-needed-for-non-descriptor-stack-frame)
- number-stack-displacement))))
+ (when cur-nfp
+ (inst add nsp-tn cur-nfp
+ (- (bytes-needed-for-non-descriptor-stack-frame)
+ number-stack-displacement))))
;; Check for the single case.
(inst cmp nvals-arg (fixnumize 1))
(move csp-tn cfp-tn)
(move cfp-tn old-fp-arg)
(lisp-return lra-arg :offset 2)
-
+
;; Nope, not the single case.
(emit-label not-single)
(move old-fp old-fp-arg)
;;; Get the lexical environment from it's passing location.
(define-vop (setup-closure-environment)
(:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
- :to (:result 0))
- lexenv)
+ :to (:result 0))
+ lexenv)
(:results (closure :scs (descriptor-reg)))
(:info label)
(:ignore label)
(move closure lexenv)))
;;; Copy a more arg from the argument area to the end of the current frame.
-;;; Fixed is the number of non-more arguments.
+;;; Fixed is the number of non-more arguments.
(define-vop (copy-more-arg)
(:temporary (:sc any-reg :offset nl0-offset) result)
(:temporary (:sc any-reg :offset nl1-offset) count)
(:info fixed)
(:generator 20
(let ((loop (gen-label))
- (do-regs (gen-label))
- (done (gen-label)))
+ (do-regs (gen-label))
+ (done (gen-label)))
(when (< fixed register-arg-count)
- ;; Save a pointer to the results so we can fill in register args.
- ;; We don't need this if there are more fixed args than reg args.
- (move result csp-tn))
+ ;; Save a pointer to the results so we can fill in register args.
+ ;; We don't need this if there are more fixed args than reg args.
+ (move result csp-tn))
;; Allocate the space on the stack.
(cond ((zerop fixed)
- (inst cmp nargs-tn)
- (inst b :eq done)
- (inst add csp-tn csp-tn nargs-tn))
- (t
- (inst subcc count nargs-tn (fixnumize fixed))
- (inst b :le done)
- (inst nop)
- (inst add csp-tn csp-tn count)))
+ (inst cmp nargs-tn)
+ (inst b :eq done)
+ (inst add csp-tn csp-tn nargs-tn))
+ (t
+ (inst subcc count nargs-tn (fixnumize fixed))
+ (inst b :le done)
+ (inst nop)
+ (inst add csp-tn csp-tn count)))
(when (< fixed register-arg-count)
- ;; We must stop when we run out of stack args, not when we run out of
- ;; more args.
- (inst subcc count nargs-tn (fixnumize register-arg-count))
- ;; Everything of interest in registers.
- (inst b :le do-regs))
+ ;; We must stop when we run out of stack args, not when we run out of
+ ;; more args.
+ (inst subcc count nargs-tn (fixnumize register-arg-count))
+ ;; Everything of interest in registers.
+ (inst b :le do-regs))
;; Initialize dst to be end of stack.
(move dst csp-tn)
;; Initialize src to be end of args.
(emit-label do-regs)
(when (< fixed register-arg-count)
- ;; Now we have to deposit any more args that showed up in registers.
- (inst subcc count nargs-tn (fixnumize fixed))
- (do ((i fixed (1+ i)))
- ((>= i register-arg-count))
- ;; Don't deposit any more than there are.
- (inst b :eq done)
- (inst subcc count (fixnumize 1))
- ;; Store it relative to the pointer saved at the start.
- (storew (nth i *register-arg-tns*) result (- i fixed))))
+ ;; Now we have to deposit any more args that showed up in registers.
+ (inst subcc count nargs-tn (fixnumize fixed))
+ (do ((i fixed (1+ i)))
+ ((>= i register-arg-count))
+ ;; Don't deposit any more than there are.
+ (inst b :eq done)
+ (inst subcc count (fixnumize 1))
+ ;; Store it relative to the pointer saved at the start.
+ (storew (nth i *register-arg-tns*) result (- i fixed))))
(emit-label done))))
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
- (count-arg :target count :scs (any-reg)))
+ (count-arg :target count :scs (any-reg)))
(:arg-types * tagged-num)
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
(:node-var node)
(:generator 20
(let* ((enter (gen-label))
- (loop (gen-label))
- (done (gen-label))
- (dx-p (node-stack-allocate-p node))
- (alloc-area-tn (if dx-p csp-tn alloc-tn)))
+ (loop (gen-label))
+ (done (gen-label))
+ (dx-p (node-stack-allocate-p node))
+ (alloc-area-tn (if dx-p csp-tn alloc-tn)))
(move context context-arg)
(move count count-arg)
;; Check to see if there are any arguments.
;; We need to do this atomically.
(pseudo-atomic ()
- (when dx-p
- (align-csp temp))
- ;; Allocate a cons (2 words) for each item.
- (inst andn result alloc-area-tn lowtag-mask)
- (inst or result list-pointer-lowtag)
- (move dst result)
- (inst sll temp count 1)
- (inst b enter)
- (inst add alloc-area-tn temp)
-
- ;; Compute the next cons and store it in the current one.
- (emit-label loop)
- (inst add dst dst (* 2 n-word-bytes))
- (storew dst dst -1 list-pointer-lowtag)
-
- ;; Grab one value.
- (emit-label enter)
- (loadw temp context)
- (inst add context context n-word-bytes)
-
- ;; Dec count, and if != zero, go back for more.
- (inst subcc count (fixnumize 1))
- (inst b :gt loop)
-
- ;; Store the value into the car of the current cons (in the delay
- ;; slot).
- (storew temp dst 0 list-pointer-lowtag)
-
- ;; NIL out the last cons.
- (storew null-tn dst 1 list-pointer-lowtag))
+ (when dx-p
+ (align-csp temp))
+ ;; Allocate a cons (2 words) for each item.
+ (inst andn result alloc-area-tn lowtag-mask)
+ (inst or result list-pointer-lowtag)
+ (move dst result)
+ (inst sll temp count 1)
+ (inst b enter)
+ (inst add alloc-area-tn temp)
+
+ ;; Compute the next cons and store it in the current one.
+ (emit-label loop)
+ (inst add dst dst (* 2 n-word-bytes))
+ (storew dst dst -1 list-pointer-lowtag)
+
+ ;; Grab one value.
+ (emit-label enter)
+ (loadw temp context)
+ (inst add context context n-word-bytes)
+
+ ;; Dec count, and if != zero, go back for more.
+ (inst subcc count (fixnumize 1))
+ (inst b :gt loop)
+
+ ;; Store the value into the car of the current cons (in the delay
+ ;; slot).
+ (storew temp dst 0 list-pointer-lowtag)
+
+ ;; NIL out the last cons.
+ (storew null-tn dst 1 list-pointer-lowtag))
(emit-label done))))
(:arg-types tagged-num (: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
(: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)))
(inst cmp nargs (fixnumize count))
(if (member :sparc-v9 *backend-subfeatures*)
- ;; Assume we don't take the branch
- (inst b :ne err-lab :pn)
- (inst b :ne err-lab))
+ ;; Assume we don't take the branch
+ (inst b :ne err-lab :pn)
+ (inst b :ne err-lab))
(inst nop))))
;;; Signal various errors.
(macrolet ((frob (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)))))
(frob arg-count-error invalid-arg-count-error
sb!c::%arg-count-error nargs)
(frob 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)))
+ (value :scs (descriptor-reg any-reg)))
(:info name offset lowtag)
(:ignore name)
(:results)
(:policy :fast-safe)
(:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
- (fdefn :scs (descriptor-reg)))
+ (fdefn :scs (descriptor-reg)))
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg)) type)
(:results (result :scs (descriptor-reg)))
;;; symbol.
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
- (symbol :scs (descriptor-reg)))
+ (symbol :scs (descriptor-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:generator 5
(loadw temp symbol symbol-value-slot other-pointer-lowtag)
(:temporary (:scs (descriptor-reg)) symbol value)
(:generator 0
(let ((loop (gen-label))
- (skip (gen-label))
- (done (gen-label)))
+ (skip (gen-label))
+ (done (gen-label)))
(move where arg)
(inst cmp where bsp-tn)
(inst b :eq done)
(:arg-types * (:constant index) *))
(define-vop (instance-index-ref word-index-ref)
- (:policy :fast-safe)
+ (:policy :fast-safe)
(:translate %instance-ref)
(:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types * positive-fixnum))
(define-vop (instance-index-set word-index-set)
- (:policy :fast-safe)
+ (:policy :fast-safe)
(:translate %instance-set)
(:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types * positive-fixnum *))
(:translate %raw-instance-ref/word)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg)))
+ (index :scs (any-reg)))
(:arg-types * positive-fixnum)
(:results (value :scs (unsigned-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(:translate %raw-instance-set/word)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
- (index :scs (any-reg))
+ (index :scs (any-reg))
(value :scs (unsigned-reg)))
(:arg-types * positive-fixnum unsigned-num)
(:results (result :scs (unsigned-reg)))
(: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)
(:results (value :scs (single-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(: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)
(:results (result :scs (single-reg)))
(:result-types single-float)
(: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)
(:results (value :scs (double-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(: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)
(:results (result :scs (double-reg)))
(:result-types double-float)
(: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)
(:results (value :scs (complex-single-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(: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)
(:results (result :scs (complex-single-reg)))
(:result-types complex-single-float)
(- (* (- instance-slots-offset 2) n-word-bytes)
instance-pointer-lowtag))
(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 stf value-real object offset)
(unless (location= result-real value-real)
(inst fmovs result-real value-real)))
(inst add offset offset n-word-bytes)
(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 stf value-imag object offset)
(unless (location= result-imag value-imag)
(inst fmovs result-imag value-imag)))))
(: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)
(:results (value :scs (complex-double-reg)))
(:temporary (:scs (non-descriptor-reg)) offset)
(: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)
(:results (result :scs (complex-double-reg)))
(:result-types complex-double-float)
(- (* (- instance-slots-offset 4) n-word-bytes)
instance-pointer-lowtag))
(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 stdf value-real object offset)
(unless (location= result-real value-real)
(move-double-reg result-real value-real)))
(inst add offset offset (* 2 n-word-bytes))
(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 stdf value-imag object offset)
(unless (location= result-imag value-imag)
(move-double-reg result-imag value-imag)))))
;;; 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)
- :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
;;; Comparison of characters.
(define-vop (character-compare)
(:args (x :scs (character-reg))
- (y :scs (character-reg)))
+ (y :scs (character-reg)))
(:arg-types character character)
(:conditional)
(:info target not-p)
(:translate sb!kernel:stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (offset :scs (any-reg)))
+ (offset :scs (any-reg)))
(:arg-types system-area-pointer positive-fixnum)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:translate sb!kernel:%set-stack-ref)
(:policy :fast-safe)
(:args (sap :scs (sap-reg))
- (offset :scs (any-reg))
- (value :scs (descriptor-reg) :target result))
+ (offset :scs (any-reg))
+ (value :scs (descriptor-reg) :target result))
(:arg-types system-area-pointer positive-fixnum *)
(:results (result :scs (descriptor-reg)))
(:result-types *)
(:variant-vars lowtag)
(:generator 5
(let ((bogus (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(loadw temp thing 0 lowtag)
(inst srl temp n-widetag-bits)
(inst cmp temp)
(inst b :eq bogus)
(inst sll 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)))
(inst sub code thing temp)
(emit-label done)
(assemble (*elsewhere*)
- (emit-label bogus)
- (inst b done)
- (move code null-tn)))))
+ (emit-label bogus)
+ (inst b done)
+ (move code null-tn)))))
(define-vop (code-from-lra code-from-mumble)
(:translate lra-code-header)
(define-move-fun (load-double 2) (vop x y)
((double-stack) (double-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(inst lddf y nfp offset)))
(define-move-fun (store-double 2) (vop x y)
((double-reg) (double-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(inst stdf x nfp offset)))
;;; The offset may be an integer or a TN in which case it will be
(inst ldqf reg base offset))
(t
(let ((reg0 (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (tn-offset reg)))
- (reg2 (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ 2 (tn-offset reg)))))
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset reg)))
+ (reg2 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset reg)))))
(cond ((integerp offset)
- (inst lddf reg0 base offset)
- (inst lddf reg2 base (+ offset (* 2 n-word-bytes))))
- (t
- (inst lddf reg0 base offset)
- (inst add offset (* 2 n-word-bytes))
- (inst lddf reg2 base offset)
- (when restore-offset
- (inst sub offset (* 2 n-word-bytes)))))))))
+ (inst lddf reg0 base offset)
+ (inst lddf reg2 base (+ offset (* 2 n-word-bytes))))
+ (t
+ (inst lddf reg0 base offset)
+ (inst add offset (* 2 n-word-bytes))
+ (inst lddf reg2 base offset)
+ (when restore-offset
+ (inst sub offset (* 2 n-word-bytes)))))))))
#!+long-float
(define-move-fun (load-long 2) (vop x y)
((long-stack) (long-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(load-long-reg y nfp offset)))
;;; The offset may be an integer or a TN in which case it will be
(cond
((member :sparc-v9 *backend-subfeatures*)
(inst stqf reg base offset))
- (t
+ (t
(let ((reg0 (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (tn-offset reg)))
- (reg2 (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ 2 (tn-offset reg)))))
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset reg)))
+ (reg2 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset reg)))))
(cond ((integerp offset)
- (inst stdf reg0 base offset)
- (inst stdf reg2 base (+ offset (* 2 n-word-bytes))))
- (t
- (inst stdf reg0 base offset)
- (inst add offset (* 2 n-word-bytes))
- (inst stdf reg2 base offset)
- (when restore-offset
- (inst sub offset (* 2 n-word-bytes)))))))))
+ (inst stdf reg0 base offset)
+ (inst stdf reg2 base (+ offset (* 2 n-word-bytes))))
+ (t
+ (inst stdf reg0 base offset)
+ (inst add offset (* 2 n-word-bytes))
+ (inst stdf reg2 base offset)
+ (when restore-offset
+ (inst sub offset (* 2 n-word-bytes)))))))))
#!+long-float
(define-move-fun (store-long 2) (vop x y)
((long-reg) (long-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(store-long-reg x nfp offset)))
\f
(t
(dotimes (i 2)
(let ((dst (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i (tn-offset dst))))
- (src (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i (tn-offset src)))))
- (inst fmovs dst src))))))
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset dst))))
+ (src (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset src)))))
+ (inst fmovs dst src))))))
;;; Exploit the V9 long-float move instruction. This is conditional
;;; on the :sparc-v9 feature.
(t
(dotimes (i 4)
(let ((dst (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i (tn-offset dst))))
- (src (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i (tn-offset src)))))
- (inst fmovs dst src))))))
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset dst))))
+ (src (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i (tn-offset src)))))
+ (inst fmovs dst src))))))
(macrolet ((frob (vop sc format)
- `(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)
- ,@(ecase format
- (:single `((inst fmovs y x)))
- (:double `((move-double-reg y x)))
- (:long `((move-long-reg 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)
+ ,@(ecase format
+ (:single `((inst fmovs y x)))
+ (:double `((move-double-reg y x)))
+ (:long `((move-long-reg y x)))))))
+ (define-move-vop ,vop :move (,sc) (,sc)))))
(frob single-move single-reg :single)
(frob double-move double-reg :double)
#!+long-float
other-pointer-lowtag)))))))
(macrolet ((frob (name sc &rest args)
- `(progn
- (define-vop (,name move-from-float)
- (:args (x :scs (,sc) :to :save))
- (:results (y :scs (descriptor-reg)))
- (:variant ,@args))
- (define-move-vop ,name :move (,sc) (descriptor-reg)))))
+ `(progn
+ (define-vop (,name move-from-float)
+ (:args (x :scs (,sc) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:variant ,@args))
+ (define-move-vop ,name :move (,sc) (descriptor-reg)))))
(frob move-from-single single-reg :single
single-float-size single-float-widetag single-float-value-slot)
(frob move-from-double double-reg :double
double-float-size double-float-widetag double-float-value-slot)
#!+long-float
- (frob move-from-long long-reg :long
+ (frob move-from-long long-reg :long
long-float-size long-float-widetag long-float-value-slot))
(macrolet ((frob (name sc format value)
- `(progn
- (define-vop (,name)
- (:args (x :scs (descriptor-reg)))
- (:results (y :scs (,sc)))
- (:note "pointer to float coercion")
- (:generator 2
- (inst ,(ecase format
- (:single 'ldf)
- (:double 'lddf))
- y x
- (- (* ,value n-word-bytes) other-pointer-lowtag))))
- (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (,sc)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ (inst ,(ecase format
+ (:single 'ldf)
+ (:double 'lddf))
+ y x
+ (- (* ,value n-word-bytes) other-pointer-lowtag))))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-single single-reg :single single-float-value-slot)
(frob move-to-double double-reg :double double-float-value-slot))
(:note "pointer to float coercion")
(:generator 2
(load-long-reg y x (- (* long-float-value-slot n-word-bytes)
- other-pointer-lowtag))))
+ other-pointer-lowtag))))
#!+long-float
(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
(macrolet ((frob (name sc stack-sc format)
- `(progn
- (define-vop (,name)
- (:args (x :scs (,sc) :target y)
- (nfp :scs (any-reg)
- :load-if (not (sc-is y ,sc))))
- (:results (y))
- (:note "float argument move")
- (:generator ,(ecase format (:single 1) (:double 2))
- (sc-case y
- (,sc
- (unless (location= x y)
- ,@(ecase format
- (:single '((inst fmovs y x)))
- (:double '((move-double-reg y x))))))
- (,stack-sc
- (let ((offset (* (tn-offset y) n-word-bytes)))
- (inst ,(ecase format
- (:single 'stf)
- (:double 'stdf))
- x nfp offset))))))
- (define-move-vop ,name :move-arg
- (,sc descriptor-reg) (,sc)))))
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (nfp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "float argument move")
+ (:generator ,(ecase format (:single 1) (:double 2))
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ ,@(ecase format
+ (:single '((inst fmovs y x)))
+ (:double '((move-double-reg y x))))))
+ (,stack-sc
+ (let ((offset (* (tn-offset y) n-word-bytes)))
+ (inst ,(ecase format
+ (:single 'stf)
+ (:double 'stdf))
+ x nfp offset))))))
+ (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
(define-vop (move-long-float-arg)
(:args (x :scs (long-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
(:results (y))
(:note "float argument move")
(:generator 3
(sc-case y
(long-reg
(unless (location= x y)
- (move-long-reg y x)))
+ (move-long-reg y x)))
(long-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (store-long-reg x nfp offset))))))
+ (store-long-reg x nfp offset))))))
;;;
#!+long-float
(define-move-vop move-long-float-arg :move-arg
(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 (+ (tn-offset x) 2)))
+ :offset (+ (tn-offset x) 2)))
#!+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 (+ (tn-offset x) 4)))
+ :offset (+ (tn-offset x) 4)))
(define-move-fun (load-complex-single 2) (vop x y)
((complex-single-stack) (complex-single-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(let ((real-tn (complex-single-reg-real-tn y)))
(inst ldf real-tn nfp offset))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(define-move-fun (store-complex-single 2) (vop x y)
((complex-single-reg) (complex-single-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(let ((real-tn (complex-single-reg-real-tn x)))
(inst stf real-tn nfp offset))
(let ((imag-tn (complex-single-reg-imag-tn x)))
(define-move-fun (load-complex-double 4) (vop x y)
((complex-double-stack) (complex-double-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(let ((real-tn (complex-double-reg-real-tn y)))
(inst lddf real-tn nfp offset))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(define-move-fun (store-complex-double 4) (vop x y)
((complex-double-reg) (complex-double-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(let ((real-tn (complex-double-reg-real-tn x)))
(inst stdf real-tn nfp offset))
(let ((imag-tn (complex-double-reg-imag-tn x)))
(define-move-fun (load-complex-long 5) (vop x y)
((complex-long-stack) (complex-long-reg))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset x) n-word-bytes)))
+ (offset (* (tn-offset x) n-word-bytes)))
(let ((real-tn (complex-long-reg-real-tn y)))
(load-long-reg real-tn nfp offset))
(let ((imag-tn (complex-long-reg-imag-tn y)))
(define-move-fun (store-complex-long 5) (vop x y)
((complex-long-reg) (complex-long-stack))
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset y) n-word-bytes)))
+ (offset (* (tn-offset y) n-word-bytes)))
(let ((real-tn (complex-long-reg-real-tn x)))
(store-long-reg real-tn nfp offset))
(let ((imag-tn (complex-long-reg-imag-tn x)))
;;;
(define-vop (complex-single-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))))
(:note "complex single float move")
(:generator 0
;; 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-single-reg-real-tn x))
- (y-real (complex-single-reg-real-tn y)))
- (inst fmovs y-real x-real))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmovs y-real x-real))
(let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst fmovs y-imag x-imag)))))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmovs y-imag x-imag)))))
;;;
(define-move-vop complex-single-move :move
(complex-single-reg) (complex-single-reg))
(define-vop (complex-double-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))))
(:note "complex double float move")
(:generator 0
;; 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)))
- (move-double-reg y-real x-real))
+ (y-real (complex-double-reg-real-tn y)))
+ (move-double-reg y-real x-real))
(let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (move-double-reg y-imag x-imag)))))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (move-double-reg y-imag x-imag)))))
;;;
(define-move-vop complex-double-move :move
(complex-double-reg) (complex-double-reg))
#!+long-float
(define-vop (complex-long-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))))
(:note "complex long float move")
(:generator 0
;; 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-long-reg-real-tn x))
- (y-real (complex-long-reg-real-tn y)))
- (move-long-reg y-real x-real))
+ (y-real (complex-long-reg-real-tn y)))
+ (move-long-reg y-real x-real))
(let ((x-imag (complex-long-reg-imag-tn x))
- (y-imag (complex-long-reg-imag-tn y)))
- (move-long-reg y-imag x-imag)))))
+ (y-imag (complex-long-reg-imag-tn y)))
+ (move-long-reg y-imag x-imag)))))
;;;
#!+long-float
(define-move-vop complex-long-move :move
(:note "complex single float to pointer coercion")
(:generator 13
(with-fixed-allocation (y ndescr complex-single-float-widetag
- complex-single-float-size)
+ complex-single-float-size)
(let ((real-tn (complex-single-reg-real-tn x)))
(inst stf real-tn y (- (* complex-single-float-real-slot
n-word-bytes)
(:note "complex double float to pointer coercion")
(:generator 13
(with-fixed-allocation (y ndescr complex-double-float-widetag
- complex-double-float-size)
+ complex-double-float-size)
(let ((real-tn (complex-double-reg-real-tn x)))
(inst stdf real-tn y (- (* complex-double-float-real-slot
n-word-bytes)
(:note "complex long float to pointer coercion")
(:generator 13
(with-fixed-allocation (y ndescr complex-long-float-widetag
- complex-long-float-size)
+ complex-long-float-size)
(let ((real-tn (complex-long-reg-real-tn x)))
(store-long-reg real-tn y (- (* complex-long-float-real-slot
n-word-bytes)
(:generator 2
(let ((real-tn (complex-single-reg-real-tn y)))
(inst ldf real-tn x (- (* complex-single-float-real-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(inst ldf imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
(define-move-vop move-to-complex-single :move
(descriptor-reg) (complex-single-reg))
(:generator 2
(let ((real-tn (complex-double-reg-real-tn y)))
(inst lddf real-tn x (- (* complex-double-float-real-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(inst lddf imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
(define-move-vop move-to-complex-double :move
(descriptor-reg) (complex-double-reg))
(:generator 2
(let ((real-tn (complex-long-reg-real-tn y)))
(load-long-reg real-tn x (- (* complex-long-float-real-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(let ((imag-tn (complex-long-reg-imag-tn y)))
(load-long-reg imag-tn x (- (* complex-long-float-imag-slot n-word-bytes)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
#!+long-float
(define-move-vop move-to-complex-long :move
(descriptor-reg) (complex-long-reg))
;;;
(define-vop (move-complex-single-float-arg)
(:args (x :scs (complex-single-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
(:results (y))
(:note "complex single-float argument move")
(:generator 1
(sc-case y
(complex-single-reg
(unless (location= x y)
- (let ((x-real (complex-single-reg-real-tn x))
- (y-real (complex-single-reg-real-tn y)))
- (inst fmovs y-real x-real))
- (let ((x-imag (complex-single-reg-imag-tn x))
- (y-imag (complex-single-reg-imag-tn y)))
- (inst fmovs y-imag x-imag))))
+ (let ((x-real (complex-single-reg-real-tn x))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmovs y-real x-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmovs y-imag x-imag))))
(complex-single-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-single-reg-real-tn x)))
- (inst stf real-tn nfp offset))
- (let ((imag-tn (complex-single-reg-imag-tn x)))
- (inst stf imag-tn nfp (+ offset n-word-bytes))))))))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst stf real-tn nfp offset))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst stf imag-tn nfp (+ offset n-word-bytes))))))))
(define-move-vop move-complex-single-float-arg :move-arg
(complex-single-reg descriptor-reg) (complex-single-reg))
(define-vop (move-complex-double-float-arg)
(:args (x :scs (complex-double-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
(:results (y))
(:note "complex double-float argument move")
(:generator 2
(sc-case y
(complex-double-reg
(unless (location= x y)
- (let ((x-real (complex-double-reg-real-tn x))
- (y-real (complex-double-reg-real-tn y)))
- (move-double-reg y-real x-real))
- (let ((x-imag (complex-double-reg-imag-tn x))
- (y-imag (complex-double-reg-imag-tn y)))
- (move-double-reg y-imag x-imag))))
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (move-double-reg y-real x-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (move-double-reg y-imag x-imag))))
(complex-double-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-double-reg-real-tn x)))
- (inst stdf real-tn nfp offset))
- (let ((imag-tn (complex-double-reg-imag-tn x)))
- (inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (inst stdf real-tn nfp offset))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
(define-move-vop move-complex-double-float-arg :move-arg
(complex-double-reg descriptor-reg) (complex-double-reg))
#!+long-float
(define-vop (move-complex-long-float-arg)
(:args (x :scs (complex-long-reg) :target y)
- (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
(:results (y))
(:note "complex long-float argument move")
(:generator 2
(sc-case y
(complex-long-reg
(unless (location= x y)
- (let ((x-real (complex-long-reg-real-tn x))
- (y-real (complex-long-reg-real-tn y)))
- (move-long-reg y-real x-real))
- (let ((x-imag (complex-long-reg-imag-tn x))
- (y-imag (complex-long-reg-imag-tn y)))
- (move-long-reg y-imag x-imag))))
+ (let ((x-real (complex-long-reg-real-tn x))
+ (y-real (complex-long-reg-real-tn y)))
+ (move-long-reg y-real x-real))
+ (let ((x-imag (complex-long-reg-imag-tn x))
+ (y-imag (complex-long-reg-imag-tn y)))
+ (move-long-reg y-imag x-imag))))
(complex-long-stack
(let ((offset (* (tn-offset y) n-word-bytes)))
- (let ((real-tn (complex-long-reg-real-tn x)))
- (store-long-reg real-tn nfp offset))
- (let ((imag-tn (complex-long-reg-imag-tn x)))
- (store-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes)))))))))
+ (let ((real-tn (complex-long-reg-real-tn x)))
+ (store-long-reg real-tn nfp offset))
+ (let ((imag-tn (complex-long-reg-imag-tn x)))
+ (store-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes)))))))))
#!+long-float
(define-move-vop move-complex-long-float-arg :move-arg
(complex-long-reg descriptor-reg) (complex-long-reg))
(:save-p :compute-only))
(macrolet ((frob (name sc ptype)
- `(define-vop (,name float-op)
- (:args (x :scs (,sc))
- (y :scs (,sc)))
- (:results (r :scs (,sc)))
- (:arg-types ,ptype ,ptype)
- (:result-types ,ptype))))
+ `(define-vop (,name float-op)
+ (:args (x :scs (,sc))
+ (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)
#!+long-float
(frob long-float-op long-reg long-float))
(macrolet ((frob (op sinst sname scost dinst dname dcost)
- `(progn
- (define-vop (,sname single-float-op)
- (:translate ,op)
- (:generator ,scost
- (inst ,sinst r x y)))
- (define-vop (,dname double-float-op)
- (:translate ,op)
- (:generator ,dcost
- (inst ,dinst r x y))))))
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,op)
+ (:generator ,scost
+ (inst ,sinst r x y)))
+ (define-vop (,dname double-float-op)
+ (:translate ,op)
+ (:generator ,dcost
+ (inst ,dinst r x y))))))
(frob + fadds +/single-float 2 faddd +/double-float 2)
(frob - fsubs -/single-float 2 fsubd -/double-float 2)
(frob * fmuls */single-float 4 fmuld */double-float 5)
#!+long-float
(macrolet ((frob (op linst lname lcost)
- `(define-vop (,lname long-float-op)
- (:translate ,op)
- (:generator ,lcost
- (inst ,linst r x y)))))
+ `(define-vop (,lname long-float-op)
+ (:translate ,op)
+ (:generator ,lcost
+ (inst ,linst r x y)))))
(frob + faddq +/long-float 2)
(frob - fsubq -/long-float 2)
(frob * fmulq */long-float 6)
\f
(macrolet ((frob (name inst translate sc type)
- `(define-vop (,name)
- (:args (x :scs (,sc)))
- (:results (y :scs (,sc)))
- (:translate ,translate)
- (:policy :fast-safe)
- (:arg-types ,type)
- (:result-types ,type)
- (:note "inline float arithmetic")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 1
- (note-this-location vop :internal-error)
- (inst ,inst y x)))))
+ `(define-vop (,name)
+ (:args (x :scs (,sc)))
+ (:results (y :scs (,sc)))
+ (:translate ,translate)
+ (:policy :fast-safe)
+ (:arg-types ,type)
+ (:result-types ,type)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ (inst ,inst y x)))))
(frob abs/single-float fabss abs single-reg single-float)
(frob %negate/single-float fnegs %negate single-reg single-float))
;; of the bits.
(inst fnegs dst src)
(let ((dst-odd (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ 1 (tn-offset dst))))
- (src-odd (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ 1 (tn-offset src)))))
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ 1 (tn-offset dst))))
+ (src-odd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ 1 (tn-offset src)))))
(inst fmovs dst-odd src-odd)))))
(defun abs-double-reg (dst src)
;; of the bits.
(inst fabss dst src)
(let ((dst-2 (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ 1 (tn-offset dst))))
- (src-2 (make-random-tn :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ 1 (tn-offset src)))))
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ 1 (tn-offset dst))))
+ (src-2 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ 1 (tn-offset src)))))
(inst fmovs dst-2 src-2)))))
(define-vop (abs/double-float)
(t
(inst fabss y x)
(dotimes (i 3)
- (let ((y-odd (make-random-tn
- :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i 1 (tn-offset y))))
- (x-odd (make-random-tn
- :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i 1 (tn-offset x)))))
- (inst fmovs y-odd x-odd)))))))
+ (let ((y-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset y))))
+ (x-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset x)))))
+ (inst fmovs y-odd x-odd)))))))
#!+long-float
(define-vop (%negate/long-float)
(t
(inst fnegs y x)
(dotimes (i 3)
- (let ((y-odd (make-random-tn
- :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i 1 (tn-offset y))))
- (x-odd (make-random-tn
- :kind :normal
- :sc (sc-or-lose 'single-reg)
- :offset (+ i 1 (tn-offset x)))))
- (inst fmovs y-odd x-odd)))))))
+ (let ((y-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset y))))
+ (x-odd (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset (+ i 1 (tn-offset x)))))
+ (inst fmovs y-odd x-odd)))))))
\f
;;;; Comparison:
(inst nop)))
(macrolet ((frob (name sc ptype)
- `(define-vop (,name float-compare)
- (:args (x :scs (,sc))
- (y :scs (,sc)))
- (:arg-types ,ptype ,ptype))))
+ `(define-vop (,name float-compare)
+ (:args (x :scs (,sc))
+ (y :scs (,sc)))
+ (:arg-types ,ptype ,ptype))))
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float)
#!+long-float
(frob long-float-compare long-reg long-float))
(macrolet ((frob (translate yep nope sname dname #!+long-float lname)
- `(progn
- (define-vop (,sname single-float-compare)
- (:translate ,translate)
- (:variant :single ,yep ,nope))
- (define-vop (,dname double-float-compare)
- (:translate ,translate)
- (:variant :double ,yep ,nope))
- #!+long-float
- (define-vop (,lname long-float-compare)
- (:translate ,translate)
- (:variant :long ,yep ,nope)))))
+ `(progn
+ (define-vop (,sname single-float-compare)
+ (:translate ,translate)
+ (:variant :single ,yep ,nope))
+ (define-vop (,dname double-float-compare)
+ (:translate ,translate)
+ (:variant :double ,yep ,nope))
+ #!+long-float
+ (define-vop (,lname long-float-compare)
+ (:translate ,translate)
+ (:variant :long ,yep ,nope)))))
(frob < :l :ge </single-float </double-float #!+long-float </long-float)
(frob > :g :le >/single-float >/double-float #!+long-float >/long-float)
(frob = :eq :ne eql/single-float eql/double-float #!+long-float eql/long-float))
#!+long-float
(deftransform eql ((x y) (long-float long-float))
'(and (= (long-float-low-bits x) (long-float-low-bits y))
- (= (long-float-mid-bits x) (long-float-mid-bits y))
- (= (long-float-high-bits x) (long-float-high-bits y))
- (= (long-float-exp-bits x) (long-float-exp-bits y))))
+ (= (long-float-mid-bits x) (long-float-mid-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 inst to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (signed-reg) :target stack-temp
- :load-if (not (sc-is x signed-stack))))
- (:temporary (:scs (single-stack) :from :argument) stack-temp)
- (:temporary (:scs (single-reg) :to :result :target y) 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
- (let ((stack-tn
- (sc-case x
- (signed-reg
- (inst st x
- (current-nfp-tn vop)
- (* (tn-offset temp) n-word-bytes))
- stack-temp)
- (signed-stack
- x))))
- (inst ldf temp
- (current-nfp-tn vop)
- (* (tn-offset stack-tn) n-word-bytes))
- (note-this-location vop :internal-error)
- (inst ,inst y temp))))))
+ `(define-vop (,name)
+ (:args (x :scs (signed-reg) :target stack-temp
+ :load-if (not (sc-is x signed-stack))))
+ (:temporary (:scs (single-stack) :from :argument) stack-temp)
+ (:temporary (:scs (single-reg) :to :result :target y) 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
+ (let ((stack-tn
+ (sc-case x
+ (signed-reg
+ (inst st x
+ (current-nfp-tn vop)
+ (* (tn-offset temp) n-word-bytes))
+ stack-temp)
+ (signed-stack
+ x))))
+ (inst ldf temp
+ (current-nfp-tn vop)
+ (* (tn-offset stack-tn) n-word-bytes))
+ (note-this-location vop :internal-error)
+ (inst ,inst y temp))))))
(frob %single-float/signed %single-float fitos single-reg single-float)
(frob %double-float/signed %double-float fitod double-reg double-float)
#!+long-float
(frob %long-float/signed %long-float fitoq long-reg long-float))
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
- `(define-vop (,name)
- (:args (x :scs (,from-sc)))
- (: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)))
+ (: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 fdtos
double-reg double-float single-reg single-float)
#!+long-float
double-reg double-float long-reg long-float))
(macrolet ((frob (trans from-sc from-type inst)
- `(define-vop (,(symbolicate trans "/" from-type))
- (:args (x :scs (,from-sc) :target temp))
- (:temporary (:from (:argument 0) :sc single-reg) temp)
- (:temporary (:scs (signed-stack)) stack-temp)
- (:results (y :scs (signed-reg)
- :load-if (not (sc-is y signed-stack))))
- (: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
- (note-this-location vop :internal-error)
- (inst ,inst temp x)
- (sc-case y
- (signed-stack
- (inst stf temp (current-nfp-tn vop)
- (* (tn-offset y) n-word-bytes)))
- (signed-reg
- (inst stf temp (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst ld y (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))))))))
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc) :target temp))
+ (:temporary (:from (:argument 0) :sc single-reg) temp)
+ (:temporary (:scs (signed-stack)) stack-temp)
+ (:results (y :scs (signed-reg)
+ :load-if (not (sc-is y signed-stack))))
+ (: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
+ (note-this-location vop :internal-error)
+ (inst ,inst temp x)
+ (sc-case y
+ (signed-stack
+ (inst stf temp (current-nfp-tn vop)
+ (* (tn-offset y) n-word-bytes)))
+ (signed-reg
+ (inst stf temp (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst ld y (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))))))))
(frob %unary-truncate single-reg single-float fstoi)
(frob %unary-truncate double-reg double-float fdtoi)
#!+long-float
(deftransform %unary-round ((x) (float) (signed-byte 32))
'(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
- (extra (- x trunc))
- (absx (abs extra))
- (one-half (float 1/2 x)))
+ (extra (- x trunc))
+ (absx (abs extra))
+ (one-half (float 1/2 x)))
(if (if (oddp trunc)
- (>= absx one-half)
- (> absx one-half))
- (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
- trunc)))
+ (>= absx one-half)
+ (> absx one-half))
+ (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
+ trunc)))
(define-vop (make-single-float)
(:args (bits :scs (signed-reg) :target res
- :load-if (not (sc-is bits signed-stack))))
+ :load-if (not (sc-is bits signed-stack))))
(:results (res :scs (single-reg)
- :load-if (not (sc-is res single-stack))))
+ :load-if (not (sc-is res single-stack))))
(:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
(:temporary (:scs (signed-stack)) stack-temp)
(:arg-types signed-num)
(sc-case bits
(signed-reg
(sc-case res
- (single-reg
- (inst st bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst ldf res (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
- (single-stack
- (inst st bits (current-nfp-tn vop)
- (* (tn-offset res) n-word-bytes)))))
+ (single-reg
+ (inst st bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst ldf res (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (single-stack
+ (inst st bits (current-nfp-tn vop)
+ (* (tn-offset res) n-word-bytes)))))
(signed-stack
(sc-case res
- (single-reg
- (inst ldf res (current-nfp-tn vop)
- (* (tn-offset bits) n-word-bytes)))
- (single-stack
- (unless (location= bits res)
- (inst ld temp (current-nfp-tn vop)
- (* (tn-offset bits) n-word-bytes))
- (inst st temp (current-nfp-tn vop)
- (* (tn-offset res) n-word-bytes)))))))))
+ (single-reg
+ (inst ldf res (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes)))
+ (single-stack
+ (unless (location= bits res)
+ (inst ld temp (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes))
+ (inst st temp (current-nfp-tn vop)
+ (* (tn-offset res) n-word-bytes)))))))))
(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)
- :load-if (not (sc-is res double-stack))))
+ :load-if (not (sc-is res double-stack))))
(:temporary (:scs (double-stack)) temp)
(:arg-types signed-num unsigned-num)
(:result-types double-float)
(:vop-var vop)
(:generator 2
(let ((stack-tn (sc-case res
- (double-stack res)
- (double-reg temp))))
+ (double-stack res)
+ (double-reg temp))))
(inst st hi-bits (current-nfp-tn vop)
- (* (tn-offset stack-tn) n-word-bytes))
+ (* (tn-offset stack-tn) n-word-bytes))
(inst st lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-tn)) n-word-bytes)))
+ (* (1+ (tn-offset stack-tn)) n-word-bytes)))
(when (sc-is res double-reg)
(inst lddf res (current-nfp-tn vop)
- (* (tn-offset temp) n-word-bytes)))))
+ (* (tn-offset temp) n-word-bytes)))))
#!+long-float
(define-vop (make-long-float)
(:args (hi-bits :scs (signed-reg))
- (lo1-bits :scs (unsigned-reg))
- (lo2-bits :scs (unsigned-reg))
- (lo3-bits :scs (unsigned-reg)))
+ (lo1-bits :scs (unsigned-reg))
+ (lo2-bits :scs (unsigned-reg))
+ (lo3-bits :scs (unsigned-reg)))
(:results (res :scs (long-reg)
- :load-if (not (sc-is res long-stack))))
+ :load-if (not (sc-is res long-stack))))
(:temporary (:scs (long-stack)) temp)
(:arg-types signed-num unsigned-num unsigned-num unsigned-num)
(:result-types long-float)
(:vop-var vop)
(:generator 2
(let ((stack-tn (sc-case res
- (long-stack res)
- (long-reg temp))))
+ (long-stack res)
+ (long-reg temp))))
(inst st hi-bits (current-nfp-tn vop)
- (* (tn-offset stack-tn) n-word-bytes))
+ (* (tn-offset stack-tn) n-word-bytes))
(inst st lo1-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-tn)) n-word-bytes))
+ (* (1+ (tn-offset stack-tn)) n-word-bytes))
(inst st lo2-bits (current-nfp-tn vop)
- (* (+ 2 (tn-offset stack-tn)) n-word-bytes))
+ (* (+ 2 (tn-offset stack-tn)) n-word-bytes))
(inst st lo3-bits (current-nfp-tn vop)
- (* (+ 3 (tn-offset stack-tn)) n-word-bytes)))
+ (* (+ 3 (tn-offset stack-tn)) n-word-bytes)))
(when (sc-is res long-reg)
(load-long-reg res (current-nfp-tn vop)
- (* (tn-offset temp) n-word-bytes)))))
+ (* (tn-offset temp) 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)
- :load-if (or (sc-is float descriptor-reg single-stack)
- (not (sc-is bits signed-stack)))))
+ :load-if (or (sc-is float descriptor-reg single-stack)
+ (not (sc-is bits signed-stack)))))
(:temporary (:scs (signed-stack)) stack-temp)
(:arg-types single-float)
(:result-types signed-num)
(sc-case bits
(signed-reg
(sc-case float
- (single-reg
- (inst stf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
- (inst ld bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
- (single-stack
- (inst ld bits (current-nfp-tn vop)
- (* (tn-offset float) n-word-bytes)))
- (descriptor-reg
- (loadw bits float single-float-value-slot
- other-pointer-lowtag))))
+ (single-reg
+ (inst stf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes))
+ (inst ld bits (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
+ (single-stack
+ (inst ld bits (current-nfp-tn vop)
+ (* (tn-offset float) n-word-bytes)))
+ (descriptor-reg
+ (loadw bits float single-float-value-slot
+ other-pointer-lowtag))))
(signed-stack
(sc-case float
- (single-reg
- (inst stf float (current-nfp-tn vop)
- (* (tn-offset bits) n-word-bytes))))))))
+ (single-reg
+ (inst stf float (current-nfp-tn vop)
+ (* (tn-offset bits) n-word-bytes))))))))
(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 (:scs (double-stack)) stack-temp)
(:arg-types double-float)
(sc-case float
(double-reg
(inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
+ (* (tn-offset stack-temp) n-word-bytes))
(inst ld hi-bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ (* (tn-offset stack-temp) n-word-bytes)))
(double-stack
(inst ld hi-bits (current-nfp-tn vop)
- (* (tn-offset float) n-word-bytes)))
+ (* (tn-offset float) n-word-bytes)))
(descriptor-reg
(loadw hi-bits float double-float-value-slot
- other-pointer-lowtag)))))
+ 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 (:scs (double-stack)) stack-temp)
(:arg-types double-float)
(sc-case float
(double-reg
(inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes))
+ (* (tn-offset stack-temp) n-word-bytes))
(inst ld lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
(double-stack
(inst ld lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset float)) n-word-bytes)))
+ (* (1+ (tn-offset float)) n-word-bytes)))
(descriptor-reg
(loadw lo-bits float (1+ double-float-value-slot)
- other-pointer-lowtag)))))
+ 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 (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (tn-offset float))))
- (inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset float))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
(inst ld exp-bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ (* (tn-offset stack-temp) n-word-bytes)))
(long-stack
(inst ld exp-bits (current-nfp-tn vop)
- (* (tn-offset float) n-word-bytes)))
+ (* (tn-offset float) n-word-bytes)))
(descriptor-reg
(loadw exp-bits float long-float-value-slot
- other-pointer-lowtag)))))
+ 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 (high-bits :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (tn-offset float))))
- (inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset float))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
(inst ld high-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
(long-stack
(inst ld high-bits (current-nfp-tn vop)
- (* (1+ (tn-offset float)) n-word-bytes)))
+ (* (1+ (tn-offset float)) n-word-bytes)))
(descriptor-reg
(loadw high-bits float (1+ long-float-value-slot)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-mid-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 (mid-bits :scs (unsigned-reg)))
(:temporary (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ 2 (tn-offset float)))))
- (inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset float)))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
(inst ld mid-bits (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ (* (tn-offset stack-temp) n-word-bytes)))
(long-stack
(inst ld mid-bits (current-nfp-tn vop)
- (* (+ 2 (tn-offset float)) n-word-bytes)))
+ (* (+ 2 (tn-offset float)) n-word-bytes)))
(descriptor-reg
(loadw mid-bits float (+ 2 long-float-value-slot)
- other-pointer-lowtag)))))
+ 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 (:scs (double-stack)) stack-temp)
(:arg-types long-float)
(sc-case float
(long-reg
(let ((float (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset (+ 2 (tn-offset float)))))
- (inst stdf float (current-nfp-tn vop)
- (* (tn-offset stack-temp) n-word-bytes)))
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ 2 (tn-offset float)))))
+ (inst stdf float (current-nfp-tn vop)
+ (* (tn-offset stack-temp) n-word-bytes)))
(inst ld lo-bits (current-nfp-tn vop)
- (* (1+ (tn-offset stack-temp)) n-word-bytes)))
+ (* (1+ (tn-offset stack-temp)) n-word-bytes)))
(long-stack
(inst ld lo-bits (current-nfp-tn vop)
- (* (+ 3 (tn-offset float)) n-word-bytes)))
+ (* (+ 3 (tn-offset float)) n-word-bytes)))
(descriptor-reg
(loadw lo-bits float (+ 3 long-float-value-slot)
- other-pointer-lowtag)))))
+ other-pointer-lowtag)))))
\f
;;;; Float mode hackery:
(:temporary (:sc double-stack) temp)
(:generator 3
(let* ((nfp (current-nfp-tn vop))
- (offset (* 4 (tn-offset temp))))
+ (offset (* 4 (tn-offset temp))))
(inst stxfsr nfp offset)
;; The desired FP mode data is in the least significant 32
;; bits, which is stored at the next higher word in memory.
(:vop-var vop)
(:generator 3
(let ((nfp (current-nfp-tn vop))
- (offset (* n-word-bytes (tn-offset temp))))
+ (offset (* n-word-bytes (tn-offset temp))))
(pseudo-atomic ()
;; Get the current FSR, so we can get the new %fcc's
(inst stxfsr nfp offset)
- (inst ldx my-fsr nfp offset)
- ;; Carefully merge in the new mode bits with the rest of the
- ;; FSR. This is only needed if we care about preserving the
- ;; high 32 bits of the FSR, which contain the additional
- ;; %fcc's on the sparc V9. If not, we don't need this, but we
- ;; do need to make sure that the unused bits are written as
- ;; zeroes, according the V9 architecture manual.
- (inst sra new 0)
- (inst srlx my-fsr 32)
- (inst sllx my-fsr 32)
- (inst or my-fsr new)
- ;; Save it back and load it into the fsr register
- (inst stx my-fsr nfp offset)
- (inst ldxfsr nfp offset)
- (move res new)))))
+ (inst ldx my-fsr nfp offset)
+ ;; Carefully merge in the new mode bits with the rest of the
+ ;; FSR. This is only needed if we care about preserving the
+ ;; high 32 bits of the FSR, which contain the additional
+ ;; %fcc's on the sparc V9. If not, we don't need this, but we
+ ;; do need to make sure that the unused bits are written as
+ ;; zeroes, according the V9 architecture manual.
+ (inst sra new 0)
+ (inst srlx my-fsr 32)
+ (inst sllx my-fsr 32)
+ (inst or my-fsr new)
+ ;; Save it back and load it into the fsr register
+ (inst stx my-fsr nfp offset)
+ (inst ldxfsr nfp offset)
+ (move res new)))))
#+nil
(define-vop (set-floating-point-modes)
(:vop-var vop)
(:generator 3
(let ((nfp (current-nfp-tn vop))
- (offset (* n-word-bytes (tn-offset temp))))
+ (offset (* n-word-bytes (tn-offset temp))))
(inst stx new nfp offset)
(inst ldxfsr nfp offset)
(move res new))))
(:translate %sqrt)
(:policy :fast-safe)
(:guard (or (member :sparc-v7 *backend-subfeatures*)
- (member :sparc-v8 *backend-subfeatures*)
- (member :sparc-v9 *backend-subfeatures*)))
+ (member :sparc-v8 *backend-subfeatures*)
+ (member :sparc-v9 *backend-subfeatures*)))
(:arg-types double-float)
(:result-types double-float)
(:note "inline float arithmetic")
(define-vop (make-complex-single-float)
(:translate complex)
(:args (real :scs (single-reg) :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 fmovs r-real real)))
+ (unless (location= real r-real)
+ (inst fmovs r-real real)))
(let ((r-imag (complex-single-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (inst fmovs r-imag imag))))
+ (unless (location= imag r-imag)
+ (inst fmovs r-imag imag))))
(complex-single-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (unless (location= real r)
- (inst stf real nfp offset))
- (inst stf imag nfp (+ offset n-word-bytes)))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (unless (location= real r)
+ (inst stf real nfp offset))
+ (inst stf imag nfp (+ offset n-word-bytes)))))))
(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)
- (move-double-reg r-real real)))
+ (unless (location= real r-real)
+ (move-double-reg r-real real)))
(let ((r-imag (complex-double-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (move-double-reg r-imag imag))))
+ (unless (location= imag r-imag)
+ (move-double-reg r-imag imag))))
(complex-double-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (unless (location= real r)
- (inst stdf real nfp offset))
- (inst stdf imag nfp (+ offset (* 2 n-word-bytes))))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (unless (location= real r)
+ (inst stdf real nfp offset))
+ (inst stdf imag nfp (+ offset (* 2 n-word-bytes))))))))
#!+long-float
(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-long-reg-real-tn r)))
- (unless (location= real r-real)
- (move-long-reg r-real real)))
+ (unless (location= real r-real)
+ (move-long-reg r-real real)))
(let ((r-imag (complex-long-reg-imag-tn r)))
- (unless (location= imag r-imag)
- (move-long-reg r-imag imag))))
+ (unless (location= imag r-imag)
+ (move-long-reg r-imag imag))))
(complex-long-stack
(let ((nfp (current-nfp-tn vop))
- (offset (* (tn-offset r) n-word-bytes)))
- (unless (location= real r)
- (store-long-reg real nfp offset))
- (store-long-reg imag nfp (+ offset (* 4 n-word-bytes))))))))
+ (offset (* (tn-offset r) n-word-bytes)))
+ (unless (location= real r)
+ (store-long-reg real nfp offset))
+ (store-long-reg imag nfp (+ offset (* 4 n-word-bytes))))))))
(define-vop (complex-single-float-value)
(:args (x :scs (complex-single-reg) :target r
- :load-if (not (sc-is x complex-single-stack))))
+ :load-if (not (sc-is x complex-single-stack))))
(:arg-types complex-single-float)
(:results (r :scs (single-reg)))
(:result-types single-float)
(sc-case x
(complex-single-reg
(let ((value-tn (ecase slot
- (:real (complex-single-reg-real-tn x))
- (:imag (complex-single-reg-imag-tn x)))))
- (unless (location= value-tn r)
- (inst fmovs r value-tn))))
+ (:real (complex-single-reg-real-tn x))
+ (:imag (complex-single-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst fmovs r value-tn))))
(complex-single-stack
(inst ldf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
- (tn-offset x))
- n-word-bytes))))))
+ (tn-offset x))
+ n-word-bytes))))))
(define-vop (realpart/complex-single-float complex-single-float-value)
(:translate realpart)
(define-vop (complex-double-float-value)
(:args (x :scs (complex-double-reg) :target r
- :load-if (not (sc-is x complex-double-stack))))
+ :load-if (not (sc-is x complex-double-stack))))
(:arg-types complex-double-float)
(:results (r :scs (double-reg)))
(:result-types double-float)
(sc-case x
(complex-double-reg
(let ((value-tn (ecase slot
- (:real (complex-double-reg-real-tn x))
- (:imag (complex-double-reg-imag-tn x)))))
- (unless (location= value-tn r)
- (move-double-reg r value-tn))))
+ (:real (complex-double-reg-real-tn x))
+ (:imag (complex-double-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (move-double-reg r value-tn))))
(complex-double-stack
(inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
- (tn-offset x))
- n-word-bytes))))))
+ (tn-offset x))
+ n-word-bytes))))))
(define-vop (realpart/complex-double-float complex-double-float-value)
(:translate realpart)
#!+long-float
(define-vop (complex-long-float-value)
(:args (x :scs (complex-long-reg) :target r
- :load-if (not (sc-is x complex-long-stack))))
+ :load-if (not (sc-is x complex-long-stack))))
(:arg-types complex-long-float)
(:results (r :scs (long-reg)))
(:result-types long-float)
(sc-case x
(complex-long-reg
(let ((value-tn (ecase slot
- (:real (complex-long-reg-real-tn x))
- (:imag (complex-long-reg-imag-tn x)))))
- (unless (location= value-tn r)
- (move-long-reg r value-tn))))
+ (:real (complex-long-reg-real-tn x))
+ (:imag (complex-long-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (move-long-reg r value-tn))))
(complex-long-stack
(load-long-reg r (current-nfp-tn vop)
- (* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x))
- n-word-bytes))))))
+ (* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x))
+ n-word-bytes))))))
#!+long-float
(define-vop (realpart/complex-long-float complex-long-float-value)
(macrolet
((frob (float-type fneg cost)
(let* ((vop-name (symbolicate "%NEGATE/COMPLEX-" float-type))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg)))
- (:arg-types ,c-type)
- (:results (r :scs (,complex-reg)))
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate %negate)
- (:generator ,cost
- (let ((xr (,real-tn x))
- (xi (,imag-tn x))
- (rr (,real-tn r))
- (ri (,imag-tn r)))
- (,@fneg rr xr)
- (,@fneg ri xi)))))))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg)))
+ (:arg-types ,c-type)
+ (:results (r :scs (,complex-reg)))
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate %negate)
+ (:generator ,cost
+ (let ((xr (,real-tn x))
+ (xi (,imag-tn x))
+ (rr (,real-tn r))
+ (ri (,imag-tn r)))
+ (,@fneg rr xr)
+ (,@fneg ri xi)))))))
(frob single (inst fnegs) 4)
(frob double (negate-double-reg) 4))
(macrolet
((frob (op inst float-type cost)
(let* ((vop-name (symbolicate (symbol-name op) "/COMPLEX-" float-type "-FLOAT"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg)) (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate ,op)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,inst rr xr yr)
- (inst ,inst ri xi yi)))))))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg)) (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate ,op)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,inst rr xr yr)
+ (inst ,inst ri xi yi)))))))
(frob + fadds single 4)
(frob + faddd double 4)
(frob - fsubs single 4)
(macrolet
((frob (size op fop fmov cost)
(let ((vop-name (symbolicate "COMPLEX-" size "-FLOAT-"
- op
- "-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (r-type (symbolicate size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,real-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,r-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float/float arithmetic")
- (:translate ,op)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,fop rr xr y)
- (unless (location= ri xi)
- (,@fmov ri xi))))))))
-
+ op
+ "-" size "-FLOAT"))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (r-type (symbolicate size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,real-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,r-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float/float arithmetic")
+ (:translate ,op)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fop rr xr y)
+ (unless (location= ri xi)
+ (,@fmov ri xi))))))))
+
(frob single + fadds (inst fmovs) 2)
(frob single - fsubs (inst fmovs) 2)
(frob double + faddd (move-double-reg) 4)
(macrolet
((frob (size fop fmov cost)
(let ((vop-name
- (symbolicate size "-FLOAT-+-COMPLEX-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (r-type (symbolicate size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (y :scs (,real-reg))
- (x :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,r-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float/float arithmetic")
- (:translate +)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,fop rr xr y)
- (unless (location= ri xi)
- (,@fmov ri xi))))))))
+ (symbolicate size "-FLOAT-+-COMPLEX-" size "-FLOAT"))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (r-type (symbolicate size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (y :scs (,real-reg))
+ (x :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,r-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float/float arithmetic")
+ (:translate +)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fop rr xr y)
+ (unless (location= ri xi)
+ (,@fmov ri xi))))))))
(frob single fadds (inst fmovs) 1)
(frob double faddd (move-double-reg) 2))
(macrolet
((frob (size fop fneg cost)
(let ((vop-name (symbolicate size "-FLOAT---COMPLEX-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (r-type (symbolicate size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (single-float---complex-single-float)
- (:args (x :scs (,real-reg)) (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,r-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float/float arithmetic")
- (:translate -)
- (:generator ,cost
- (let ((yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,fop rr x yr)
- (,@fneg ri yi))))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (r-type (symbolicate size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (single-float---complex-single-float)
+ (:args (x :scs (,real-reg)) (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,r-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float/float arithmetic")
+ (:translate -)
+ (:generator ,cost
+ (let ((yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fop rr x yr)
+ (,@fneg ri yi))))
))
(frob single fsubs (inst fnegs) 2)
(macrolet
((frob (size fmul fadd fsub cost)
(let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float multiplication")
- (:translate *)
- (:temporary (:scs (,real-reg)) prod-1 prod-2 prod-3 prod-4)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r)))
- ;; All of the temps are needed in case the result TN happens to
- ;; be the same as one of the arg TN's
- (inst ,fmul prod-1 xr yr)
- (inst ,fmul prod-2 xi yi)
- (inst ,fmul prod-3 xr yi)
- (inst ,fmul prod-4 xi yr)
- (inst ,fsub rr prod-1 prod-2)
- (inst ,fadd ri prod-3 prod-4)))))))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float multiplication")
+ (:translate *)
+ (:temporary (:scs (,real-reg)) prod-1 prod-2 prod-3 prod-4)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ ;; All of the temps are needed in case the result TN happens to
+ ;; be the same as one of the arg TN's
+ (inst ,fmul prod-1 xr yr)
+ (inst ,fmul prod-2 xi yi)
+ (inst ,fmul prod-3 xr yi)
+ (inst ,fmul prod-4 xi yr)
+ (inst ,fsub rr prod-1 prod-2)
+ (inst ,fadd ri prod-3 prod-4)))))))
(frob single fmuls fadds fsubs 6)
(frob double fmuld faddd fsubd 6))
(macrolet
((frob (size fmul fadd fsub cost)
(let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" size "-REG"))
- (real-reg (symbolicate size "-REG"))
- (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float multiplication")
- (:translate *)
- (:temporary (:scs (,real-reg)) p1 p2)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (cond ((location= r x)
- (inst ,fmul p1 xr yr)
- (inst ,fmul p2 xr yi)
- (inst ,fmul rr xi yi)
- (inst ,fsub rr p1 xr)
- (inst ,fmul p1 xi yr)
- (inst ,fadd ri p2 p1))
- ((location= r y)
- (inst ,fmul p1 yr xr)
- (inst ,fmul p2 yr xi)
- (inst ,fmul rr yi xi)
- (inst ,fsub rr p1 rr)
- (inst ,fmul p1 yi xr)
- (inst ,fadd ri p2 p1))
- (t
- (inst ,fmul rr yr xr)
- (inst ,fmul ri xi yi)
- (inst ,fsub rr rr ri)
- (inst ,fmul p1 xr yi)
- (inst ,fmul ri xi yr)
- (inst ,fadd ri ri p1)))))))))
+ (complex-reg (symbolicate "COMPLEX-" size "-REG"))
+ (real-reg (symbolicate size "-REG"))
+ (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float multiplication")
+ (:translate *)
+ (:temporary (:scs (,real-reg)) p1 p2)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (cond ((location= r x)
+ (inst ,fmul p1 xr yr)
+ (inst ,fmul p2 xr yi)
+ (inst ,fmul rr xi yi)
+ (inst ,fsub rr p1 xr)
+ (inst ,fmul p1 xi yr)
+ (inst ,fadd ri p2 p1))
+ ((location= r y)
+ (inst ,fmul p1 yr xr)
+ (inst ,fmul p2 yr xi)
+ (inst ,fmul rr yi xi)
+ (inst ,fsub rr p1 rr)
+ (inst ,fmul p1 yi xr)
+ (inst ,fadd ri p2 p1))
+ (t
+ (inst ,fmul rr yr xr)
+ (inst ,fmul ri xi yi)
+ (inst ,fsub rr rr ri)
+ (inst ,fmul p1 xr yi)
+ (inst ,fmul ri xi yr)
+ (inst ,fadd ri ri p1)))))))))
(frob single fmuls fadds fsubs 6)
(frob double fmuld faddd fsubd 6))
(macrolet
((frob (float-type fmul mov cost)
(let* ((vop-name (symbolicate "COMPLEX-"
- float-type
- "-FLOAT-*-"
- float-type
- "-FLOAT"))
- (vop-name-r (symbolicate float-type
- "-FLOAT-*-COMPLEX-"
- float-type
- "-FLOAT"))
- (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
- (real-sc-type (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (r-type (symbolicate float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(progn
- ;; Complex * float
- (define-vop (,vop-name)
- (:args (x :scs (,complex-sc-type))
- (y :scs (,real-sc-type)))
- (:results (r :scs (,complex-sc-type)))
- (:arg-types ,c-type ,r-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate *)
- (:temporary (:scs (,real-sc-type)) temp)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (cond ((location= y rr)
- (inst ,fmul temp xr y) ; xr * y
- (inst ,fmul ri xi y) ; xi * yi
- (,@mov rr temp))
- (t
- (inst ,fmul rr xr y)
- (inst ,fmul ri xi y))))))
- ;; Float * complex
- (define-vop (,vop-name-r)
- (:args (y :scs (,real-sc-type))
- (x :scs (,complex-sc-type)))
- (:results (r :scs (,complex-sc-type)))
- (:arg-types ,r-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate *)
- (:temporary (:scs (,real-sc-type)) temp)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (cond ((location= y rr)
- (inst ,fmul temp xr y) ; xr * y
- (inst ,fmul ri xi y) ; xi * yi
- (,@mov rr temp))
- (t
- (inst ,fmul rr xr y)
- (inst ,fmul ri xi y))))))))))
+ float-type
+ "-FLOAT-*-"
+ float-type
+ "-FLOAT"))
+ (vop-name-r (symbolicate float-type
+ "-FLOAT-*-COMPLEX-"
+ float-type
+ "-FLOAT"))
+ (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-sc-type (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(progn
+ ;; Complex * float
+ (define-vop (,vop-name)
+ (:args (x :scs (,complex-sc-type))
+ (y :scs (,real-sc-type)))
+ (:results (r :scs (,complex-sc-type)))
+ (:arg-types ,c-type ,r-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate *)
+ (:temporary (:scs (,real-sc-type)) temp)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (cond ((location= y rr)
+ (inst ,fmul temp xr y) ; xr * y
+ (inst ,fmul ri xi y) ; xi * yi
+ (,@mov rr temp))
+ (t
+ (inst ,fmul rr xr y)
+ (inst ,fmul ri xi y))))))
+ ;; Float * complex
+ (define-vop (,vop-name-r)
+ (:args (y :scs (,real-sc-type))
+ (x :scs (,complex-sc-type)))
+ (:results (r :scs (,complex-sc-type)))
+ (:arg-types ,r-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate *)
+ (:temporary (:scs (,real-sc-type)) temp)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (cond ((location= y rr)
+ (inst ,fmul temp xr y) ; xr * y
+ (inst ,fmul ri xi y) ; xi * yi
+ (,@mov rr temp))
+ (t
+ (inst ,fmul rr xr y)
+ (inst ,fmul ri xi y))))))))))
(frob single fmuls (inst fmovs) 4)
(frob double fmuld (move-double-reg) 4))
;;
;; We do the similar thing when |yi| > |yr|. The result is
;;
-;;
+;;
;; (xr + i*xi) (xr + i*xi)
;; ----------- = -----------------
;; (yr + i*yi) yi*((yr/yi) + i)
(macrolet
((frob (float-type fcmp fadd fsub fmul fdiv fabs fmov cost)
(let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float division")
- (:translate /)
- (:temporary (:sc ,real-reg) ratio)
- (:temporary (:sc ,real-reg) den)
- (:temporary (:sc ,real-reg) temp-r)
- (:temporary (:sc ,real-reg) temp-i)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r))
- (bigger (gen-label))
- (done (gen-label)))
- (,@fabs ratio yr)
- (,@fabs den yi)
- (inst ,fcmp ratio den)
- (unless (member :sparc-v9 *backend-subfeatures*)
- (inst nop))
- (inst fb :ge bigger)
- (inst nop)
- ;; The case of |yi| <= |yr|
- (inst ,fdiv ratio yi yr) ; ratio = yi/yr
- (inst ,fmul den ratio yi)
- (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
-
- (inst ,fmul temp-r ratio xi)
- (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
- (inst ,fdiv temp-r temp-r den)
-
- (inst ,fmul temp-i ratio xr)
- (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
- (inst b done)
- (inst ,fdiv temp-i temp-i den)
-
- (emit-label bigger)
- ;; The case of |yi| > |yr|
- (inst ,fdiv ratio yr yi) ; ratio = yr/yi
- (inst ,fmul den ratio yr)
- (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
-
- (inst ,fmul temp-r ratio xr)
- (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
- (inst ,fdiv temp-r temp-r den)
-
- (inst ,fmul temp-i ratio xi)
- (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
- (inst ,fdiv temp-i temp-i den)
-
- (emit-label done)
- (unless (location= temp-r rr)
- (,@fmov rr temp-r))
- (unless (location= temp-i ri)
- (,@fmov ri temp-i))
- ))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp-r)
+ (:temporary (:sc ,real-reg) temp-i)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r))
+ (bigger (gen-label))
+ (done (gen-label)))
+ (,@fabs ratio yr)
+ (,@fabs den yi)
+ (inst ,fcmp ratio den)
+ (unless (member :sparc-v9 *backend-subfeatures*)
+ (inst nop))
+ (inst fb :ge bigger)
+ (inst nop)
+ ;; The case of |yi| <= |yr|
+ (inst ,fdiv ratio yi yr) ; ratio = yi/yr
+ (inst ,fmul den ratio yi)
+ (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+
+ (inst ,fmul temp-r ratio xi)
+ (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
+ (inst ,fdiv temp-r temp-r den)
+
+ (inst ,fmul temp-i ratio xr)
+ (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
+ (inst b done)
+ (inst ,fdiv temp-i temp-i den)
+
+ (emit-label bigger)
+ ;; The case of |yi| > |yr|
+ (inst ,fdiv ratio yr yi) ; ratio = yr/yi
+ (inst ,fmul den ratio yr)
+ (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+
+ (inst ,fmul temp-r ratio xr)
+ (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
+ (inst ,fdiv temp-r temp-r den)
+
+ (inst ,fmul temp-i ratio xi)
+ (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
+ (inst ,fdiv temp-i temp-i den)
+
+ (emit-label done)
+ (unless (location= temp-r rr)
+ (,@fmov rr temp-r))
+ (unless (location= temp-i ri)
+ (,@fmov ri temp-i))
+ ))))))
(frob single fcmps fadds fsubs fmuls fdivs (inst fabss) (inst fmovs) 15)
(frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) (move-double-reg) 15))
(macrolet
((frob (float-type fcmp fadd fsub fmul fdiv fabs cost)
(let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float division")
- (:translate /)
- (:temporary (:sc ,real-reg) ratio)
- (:temporary (:sc ,real-reg) den)
- (:temporary (:sc ,real-reg) temp-r)
- (:temporary (:sc ,real-reg) temp-i)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y))
- (rr (,real-part r))
- (ri (,imag-part r))
- (bigger (gen-label))
- (done (gen-label)))
- (,@fabs ratio yr)
- (,@fabs den yi)
- (inst ,fcmp ratio den)
- (unless (member :sparc-v9 *backend-subfeatures*)
- (inst nop))
- (inst fb :ge bigger)
- (inst nop)
- ;; The case of |yi| <= |yr|
- (inst ,fdiv ratio yi yr) ; ratio = yi/yr
- (inst ,fmul den ratio yi)
- (inst ,fmul temp-r ratio xi)
- (inst ,fmul temp-i ratio xr)
-
- (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
- (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
- (inst b done)
- (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
-
-
- (emit-label bigger)
- ;; The case of |yi| > |yr|
- (inst ,fdiv ratio yr yi) ; ratio = yr/yi
- (inst ,fmul den ratio yr)
- (inst ,fmul temp-r ratio xr)
- (inst ,fmul temp-i ratio xi)
-
- (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
- (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
-
- (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
-
- (emit-label done)
-
- (inst ,fdiv rr temp-r den)
- (inst ,fdiv ri temp-i den)
- ))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp-r)
+ (:temporary (:sc ,real-reg) temp-i)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y))
+ (rr (,real-part r))
+ (ri (,imag-part r))
+ (bigger (gen-label))
+ (done (gen-label)))
+ (,@fabs ratio yr)
+ (,@fabs den yi)
+ (inst ,fcmp ratio den)
+ (unless (member :sparc-v9 *backend-subfeatures*)
+ (inst nop))
+ (inst fb :ge bigger)
+ (inst nop)
+ ;; The case of |yi| <= |yr|
+ (inst ,fdiv ratio yi yr) ; ratio = yi/yr
+ (inst ,fmul den ratio yi)
+ (inst ,fmul temp-r ratio xi)
+ (inst ,fmul temp-i ratio xr)
+
+ (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+ (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
+ (inst b done)
+ (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
+
+
+ (emit-label bigger)
+ ;; The case of |yi| > |yr|
+ (inst ,fdiv ratio yr yi) ; ratio = yr/yi
+ (inst ,fmul den ratio yr)
+ (inst ,fmul temp-r ratio xr)
+ (inst ,fmul temp-i ratio xi)
+
+ (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+ (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
+
+ (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
+
+ (emit-label done)
+
+ (inst ,fdiv rr temp-r den)
+ (inst ,fdiv ri temp-i den)
+ ))))))
(frob single fcmps fadds fsubs fmuls fdivs (inst fabss) 15)
(frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) 15))
(macrolet
((frob (float-type fdiv cost)
(let* ((vop-name (symbolicate "COMPLEX-" float-type "-FLOAT-/-" float-type "-FLOAT"))
- (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
- (real-sc-type (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (r-type (symbolicate float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-sc-type)) (y :scs (,real-sc-type)))
- (:results (r :scs (,complex-sc-type)))
- (:arg-types ,c-type ,r-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float arithmetic")
- (:translate /)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (inst ,fdiv rr xr y) ; xr * y
- (inst ,fdiv ri xi y) ; xi * yi
- ))))))
+ (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-sc-type (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-sc-type)) (y :scs (,real-sc-type)))
+ (:results (r :scs (,complex-sc-type)))
+ (:arg-types ,c-type ,r-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float arithmetic")
+ (:translate /)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (inst ,fdiv rr xr y) ; xr * y
+ (inst ,fdiv ri xi y) ; xi * yi
+ ))))))
(frob single fdivs 2)
(frob double fdivd 2))
(macrolet
((frob (float-type fcmp fadd fmul fdiv fneg fabs cost)
(let ((vop-name (symbolicate float-type "-FLOAT-/-COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (r-type (symbolicate float-type "-FLOAT"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,real-reg))
- (y :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,r-type ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex float division")
- (:translate /)
- (:temporary (:sc ,real-reg) ratio)
- (:temporary (:sc ,real-reg) den)
- (:temporary (:sc ,real-reg) temp)
- (:generator ,cost
- (let ((yr (,real-tn y))
- (yi (,imag-tn y))
- (rr (,real-tn r))
- (ri (,imag-tn r))
- (bigger (gen-label))
- (done (gen-label)))
- (,@fabs ratio yr)
- (,@fabs den yi)
- (inst ,fcmp ratio den)
- (unless (member :sparc-v9 *backend-subfeatures*)
- (inst nop))
- (inst fb :ge bigger)
- (inst nop)
- ;; The case of |yi| <= |yr|
- (inst ,fdiv ratio yi yr) ; ratio = yi/yr
- (inst ,fmul den ratio yi)
- (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
-
- (inst ,fmul temp ratio x) ; temp = (yi/yr)*x
- (inst ,fdiv rr x den) ; rr = x/den
- (inst b done)
- (inst ,fdiv temp temp den) ; temp = (yi/yr)*x/den
-
- (emit-label bigger)
- ;; The case of |yi| > |yr|
- (inst ,fdiv ratio yr yi) ; ratio = yr/yi
- (inst ,fmul den ratio yr)
- (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
-
- (inst ,fmul temp ratio x) ; temp = (yr/yi)*x
- (inst ,fdiv rr temp den) ; rr = (yr/yi)*x/den
- (inst ,fdiv temp x den) ; temp = x/den
- (emit-label done)
-
- (,@fneg ri temp)))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,real-reg))
+ (y :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,r-type ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex float division")
+ (:translate /)
+ (:temporary (:sc ,real-reg) ratio)
+ (:temporary (:sc ,real-reg) den)
+ (:temporary (:sc ,real-reg) temp)
+ (:generator ,cost
+ (let ((yr (,real-tn y))
+ (yi (,imag-tn y))
+ (rr (,real-tn r))
+ (ri (,imag-tn r))
+ (bigger (gen-label))
+ (done (gen-label)))
+ (,@fabs ratio yr)
+ (,@fabs den yi)
+ (inst ,fcmp ratio den)
+ (unless (member :sparc-v9 *backend-subfeatures*)
+ (inst nop))
+ (inst fb :ge bigger)
+ (inst nop)
+ ;; The case of |yi| <= |yr|
+ (inst ,fdiv ratio yi yr) ; ratio = yi/yr
+ (inst ,fmul den ratio yi)
+ (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
+
+ (inst ,fmul temp ratio x) ; temp = (yi/yr)*x
+ (inst ,fdiv rr x den) ; rr = x/den
+ (inst b done)
+ (inst ,fdiv temp temp den) ; temp = (yi/yr)*x/den
+
+ (emit-label bigger)
+ ;; The case of |yi| > |yr|
+ (inst ,fdiv ratio yr yi) ; ratio = yr/yi
+ (inst ,fmul den ratio yr)
+ (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
+
+ (inst ,fmul temp ratio x) ; temp = (yr/yi)*x
+ (inst ,fdiv rr temp den) ; rr = (yr/yi)*x/den
+ (inst ,fdiv temp x den) ; temp = x/den
+ (emit-label done)
+
+ (,@fneg ri temp)))))))
(frob single fcmps fadds fmuls fdivs (inst fnegs) (inst fabss) 10)
(frob double fcmpd faddd fmuld fdivd (negate-double-reg) (abs-double-reg) 10))
(macrolet
((frob (float-type fneg fmov cost)
(let ((vop-name (symbolicate "CONJUGATE/COMPLEX-" float-type "-FLOAT"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg)))
- (:results (r :scs (,complex-reg)))
- (:arg-types ,c-type)
- (:result-types ,c-type)
- (:policy :fast-safe)
- (:note "inline complex conjugate")
- (:translate conjugate)
- (:generator ,cost
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (rr (,real-part r))
- (ri (,imag-part r)))
- (,@fneg ri xi)
- (unless (location= rr xr)
- (,@fmov rr xr))))))))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg)))
+ (:results (r :scs (,complex-reg)))
+ (:arg-types ,c-type)
+ (:result-types ,c-type)
+ (:policy :fast-safe)
+ (:note "inline complex conjugate")
+ (:translate conjugate)
+ (:generator ,cost
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (rr (,real-part r))
+ (ri (,imag-part r)))
+ (,@fneg ri xi)
+ (unless (location= rr xr)
+ (,@fmov rr xr))))))))
(frob single (inst fnegs) (inst fmovs) 4)
(frob double (negate-double-reg) (move-double-reg) 4))
(macrolet
((frob (name name-r f-type c-type)
`(progn
- (defknown ,name (,f-type ,c-type) t)
- (defknown ,name-r (,c-type ,f-type) t)
- (defun ,name (x y)
- (declare (type ,f-type x)
- (type ,c-type y))
- (,name x y))
- (defun ,name-r (x y)
- (declare (type ,c-type x)
- (type ,f-type y))
- (,name-r x y))
- )))
+ (defknown ,name (,f-type ,c-type) t)
+ (defknown ,name-r (,c-type ,f-type) t)
+ (defun ,name (x y)
+ (declare (type ,f-type x)
+ (type ,c-type y))
+ (,name x y))
+ (defun ,name-r (x y)
+ (declare (type ,c-type x)
+ (type ,f-type y))
+ (,name-r x y))
+ )))
(frob %compare-complex-single-single %compare-single-complex-single
- single-float (complex single-float))
+ single-float (complex single-float))
(frob %compare-complex-double-double %compare-double-complex-double
- double-float (complex double-float)))
-
+ double-float (complex double-float)))
+
#+nil
(macrolet
((frob (trans-1 trans-2 float-type fcmp fsub)
(let ((vop-name
- (symbolicate "COMPLEX-" float-type "-FLOAT-"
- float-type "-FLOAT-COMPARE"))
- (vop-name-r
- (symbolicate float-type "-FLOAT-COMPLEX-"
- float-type "-FLOAT-COMPARE"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (real-reg (symbolicate float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (r-type (symbolicate float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(progn
- ;; (= float complex)
- (define-vop (,vop-name)
- (:args (x :scs (,real-reg))
- (y :scs (,complex-reg)))
- (:arg-types ,r-type ,c-type)
- (:translate ,trans-1)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float/float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:sc ,real-reg) fp-zero)
- (:guard #!-:sparc-v9 nil #!+:sparc-v9 t)
- (:generator 6
- (note-this-location vop :internal-error)
- (let ((yr (,real-part y))
- (yi (,imag-part y)))
- ;; Set fp-zero to zero
- (inst ,fsub fp-zero fp-zero fp-zero)
- (inst ,fcmp x yr)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst ,fcmp yi fp-zero)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst nop))))
- ;; (= complex float)
- (define-vop (,vop-name-r)
- (:args (y :scs (,complex-reg))
- (x :scs (,real-reg)))
- (:arg-types ,c-type ,r-type)
- (:translate ,trans-2)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float/float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:sc ,real-reg) fp-zero)
- (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
- (:generator 6
- (note-this-location vop :internal-error)
- (let ((yr (,real-part y))
- (yi (,imag-part y)))
- ;; Set fp-zero to zero
- (inst ,fsub fp-zero fp-zero fp-zero)
- (inst ,fcmp x yr)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst ,fcmp yi fp-zero)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst nop))))))))
+ (symbolicate "COMPLEX-" float-type "-FLOAT-"
+ float-type "-FLOAT-COMPARE"))
+ (vop-name-r
+ (symbolicate float-type "-FLOAT-COMPLEX-"
+ float-type "-FLOAT-COMPARE"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (real-reg (symbolicate float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (r-type (symbolicate float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(progn
+ ;; (= float complex)
+ (define-vop (,vop-name)
+ (:args (x :scs (,real-reg))
+ (y :scs (,complex-reg)))
+ (:arg-types ,r-type ,c-type)
+ (:translate ,trans-1)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float/float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc ,real-reg) fp-zero)
+ (:guard #!-:sparc-v9 nil #!+:sparc-v9 t)
+ (:generator 6
+ (note-this-location vop :internal-error)
+ (let ((yr (,real-part y))
+ (yi (,imag-part y)))
+ ;; Set fp-zero to zero
+ (inst ,fsub fp-zero fp-zero fp-zero)
+ (inst ,fcmp x yr)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst ,fcmp yi fp-zero)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst nop))))
+ ;; (= complex float)
+ (define-vop (,vop-name-r)
+ (:args (y :scs (,complex-reg))
+ (x :scs (,real-reg)))
+ (:arg-types ,c-type ,r-type)
+ (:translate ,trans-2)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float/float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc ,real-reg) fp-zero)
+ (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
+ (:generator 6
+ (note-this-location vop :internal-error)
+ (let ((yr (,real-part y))
+ (yi (,imag-part y)))
+ ;; Set fp-zero to zero
+ (inst ,fsub fp-zero fp-zero fp-zero)
+ (inst ,fcmp x yr)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst ,fcmp yi fp-zero)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst nop))))))))
(frob %compare-complex-single-single %compare-single-complex-single
- single fcmps fsubs)
+ single fcmps fsubs)
(frob %compare-complex-double-double %compare-double-complex-double
- double fcmpd fsubd))
+ double fcmpd fsubd))
;; Compare two complex numbers for equality
(macrolet
((frob (float-type fcmp)
(let ((vop-name
- (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:translate =)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:generator 6
- (note-this-location vop :internal-error)
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y)))
- (inst ,fcmp xr yr)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst ,fcmp xi yi)
- (inst nop)
- (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
- (inst nop)))))))
+ (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:translate =)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 6
+ (note-this-location vop :internal-error)
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y)))
+ (inst ,fcmp xr yr)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst ,fcmp xi yi)
+ (inst nop)
+ (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
+ (inst nop)))))))
(frob single fcmps)
(frob double fcmpd))
(macrolet
((frob (float-type fcmp)
(let ((vop-name
- (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
- (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
- (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
- (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
- (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
- `(define-vop (,vop-name)
- (:args (x :scs (,complex-reg))
- (y :scs (,complex-reg)))
- (:arg-types ,c-type ,c-type)
- (:translate =)
- (:conditional)
- (:info target not-p)
- (:policy :fast-safe)
- (:note "inline complex float comparison")
- (:vop-var vop)
- (:save-p :compute-only)
- (:temporary (:sc descriptor-reg) true)
- (:guard (member :sparc-v9 *backend-subfeatures*))
- (:generator 5
- (note-this-location vop :internal-error)
- (let ((xr (,real-part x))
- (xi (,imag-part x))
- (yr (,real-part y))
- (yi (,imag-part y)))
- ;; Assume comparison is true
- (load-symbol true t)
- (inst ,fcmp xr yr)
- (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
- (inst ,fcmp xi yi)
- (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
- (inst cmp true null-tn)
- (inst b (if not-p :eq :ne) target :pt)
- (inst nop)))))))
+ (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
+ (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
+ (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
+ (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
+ (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,complex-reg))
+ (y :scs (,complex-reg)))
+ (:arg-types ,c-type ,c-type)
+ (:translate =)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline complex float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc descriptor-reg) true)
+ (:guard (member :sparc-v9 *backend-subfeatures*))
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (let ((xr (,real-part x))
+ (xi (,imag-part x))
+ (yr (,real-part y))
+ (yi (,imag-part y)))
+ ;; Assume comparison is true
+ (load-symbol true t)
+ (inst ,fcmp xr yr)
+ (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
+ (inst ,fcmp xi yi)
+ (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
+ (inst cmp true null-tn)
+ (inst b (if not-p :eq :ne) target :pt)
+ (inst nop)))))))
(frob single fcmps)
(frob double fcmpd))
;; Vops to take advantage of the conditional move instruction
;; available on the Sparc V9
-
+
(defknown (%%max %%min) ((or (unsigned-byte #.n-word-bits)
- (signed-byte #.n-word-bits)
- single-float double-float)
- (or (unsigned-byte #.n-word-bits)
- (signed-byte #.n-word-bits)
- single-float double-float))
+ (signed-byte #.n-word-bits)
+ single-float double-float)
+ (or (unsigned-byte #.n-word-bits)
+ (signed-byte #.n-word-bits)
+ single-float double-float))
(or (unsigned-byte #.n-word-bits)
(signed-byte #.n-word-bits)
single-float double-float)
(movable foldable flushable))
-;; We need these definitions for byte-compiled code
+;; We need these definitions for byte-compiled code
;;
;; Well, we (SBCL) probably don't, having deleted the byte
;; compiler. Let's see what happens if we comment out these
#+nil
(defun %%min (x y)
(declare (type (or (unsigned-byte 32) (signed-byte 32)
- single-float double-float) x y))
+ single-float double-float) x y))
(if (<= x y)
x y))
#+nil
(defun %%max (x y)
(declare (type (or (unsigned-byte 32) (signed-byte 32)
- single-float double-float) x y))
+ single-float double-float) x y))
(if (>= x y)
x y))
-#+nil
+#+nil
(macrolet
((frob (name sc-type type compare cmov cost cc max min note)
(let ((vop-name (symbolicate name "-" type "=>" type))
- (trans-name (symbolicate "%%" name)))
- `(define-vop (,vop-name)
- (:args (x :scs (,sc-type))
- (y :scs (,sc-type)))
- (:results (r :scs (,sc-type)))
- (:arg-types ,type ,type)
- (:result-types ,type)
- (:policy :fast-safe)
- (:note ,note)
- (:translate ,trans-name)
- (:guard (member :sparc-v9 *backend-subfeatures*))
- (:generator ,cost
- (inst ,compare x y)
- (cond ((location= r x)
- ;; If x < y, need to move y to r, otherwise r already has
- ;; the max.
- (inst ,cmov ,min r y ,cc))
- ((location= r y)
- ;; If x > y, need to move x to r, otherwise r already has
- ;; the max.
- (inst ,cmov ,max r x ,cc))
- (t
- ;; It doesn't matter what R is, just copy the min to R.
- (inst ,cmov ,max r x ,cc)
- (inst ,cmov ,min r y ,cc))))))))
+ (trans-name (symbolicate "%%" name)))
+ `(define-vop (,vop-name)
+ (:args (x :scs (,sc-type))
+ (y :scs (,sc-type)))
+ (:results (r :scs (,sc-type)))
+ (:arg-types ,type ,type)
+ (:result-types ,type)
+ (:policy :fast-safe)
+ (:note ,note)
+ (:translate ,trans-name)
+ (:guard (member :sparc-v9 *backend-subfeatures*))
+ (:generator ,cost
+ (inst ,compare x y)
+ (cond ((location= r x)
+ ;; If x < y, need to move y to r, otherwise r already has
+ ;; the max.
+ (inst ,cmov ,min r y ,cc))
+ ((location= r y)
+ ;; If x > y, need to move x to r, otherwise r already has
+ ;; the max.
+ (inst ,cmov ,max r x ,cc))
+ (t
+ ;; It doesn't matter what R is, just copy the min to R.
+ (inst ,cmov ,max r x ,cc)
+ (inst ,cmov ,min r y ,cc))))))))
(frob max single-reg single-float fcmps cfmovs 3
- :fcc0 :ge :l "inline float max")
+ :fcc0 :ge :l "inline float max")
(frob max double-reg double-float fcmpd cfmovd 3
- :fcc0 :ge :l "inline float max")
+ :fcc0 :ge :l "inline float max")
(frob min single-reg single-float fcmps cfmovs 3
- :fcc0 :l :ge "inline float min")
+ :fcc0 :l :ge "inline float min")
(frob min double-reg double-float fcmpd cfmovd 3
- :fcc0 :l :ge "inline float min")
+ :fcc0 :l :ge "inline float min")
;; Strictly speaking these aren't float ops, but it's convenient to
;; do them here.
;;
;; 32-bit integer operands, we add 2 more to account for the
;; untagging of fixnums, if necessary.
(frob max signed-reg signed-num cmp cmove 5
- :icc :ge :lt "inline (signed-byte 32) max")
+ :icc :ge :lt "inline (signed-byte 32) max")
(frob max unsigned-reg unsigned-num cmp cmove 5
- :icc :ge :lt "inline (unsigned-byte 32) max")
+ :icc :ge :lt "inline (unsigned-byte 32) max")
;; For fixnums, make the cost lower so we don't have to untag the
;; numbers.
(frob max any-reg tagged-num cmp cmove 3
- :icc :ge :lt "inline fixnum max")
+ :icc :ge :lt "inline fixnum max")
(frob min signed-reg signed-num cmp cmove 5
- :icc :lt :ge "inline (signed-byte 32) min")
+ :icc :lt :ge "inline (signed-byte 32) min")
(frob min unsigned-reg unsigned-num cmp cmove 5
- :icc :lt :ge "inline (unsigned-byte 32) min")
+ :icc :lt :ge "inline (unsigned-byte 32) min")
;; For fixnums, make the cost lower so we don't have to untag the
;; numbers.
(frob min any-reg tagged-num cmp cmove 3
- :icc :lt :ge "inline fixnum min"))
-
+ :icc :lt :ge "inline fixnum min"))
+
#+nil
(define-vop (max-boxed-double-float=>boxed-double-float)
(:args (x :scs (descriptor-reg))
- (y :scs (descriptor-reg)))
+ (y :scs (descriptor-reg)))
(:results (r :scs (descriptor-reg)))
(:arg-types double-float double-float)
(:result-types double-float)
(:vop-var vop)
(:generator 3
(let ((offset (- (* double-float-value-slot n-word-bytes)
- other-pointer-lowtag)))
+ other-pointer-lowtag)))
(inst lddf xval x offset)
(inst lddf yval y offset)
(inst fcmpd xval yval)
(cond ((location= r x)
- ;; If x < y, need to move y to r, otherwise r already has
- ;; the max.
- (inst cmove :l r y :fcc0))
- ((location= r y)
- ;; If x > y, need to move x to r, otherwise r already has
- ;; the max.
- (inst cmove :ge r x :fcc0))
- (t
- ;; It doesn't matter what R is, just copy the min to R.
- (inst cmove :ge r x :fcc0)
- (inst cmove :l r y :fcc0))))))
-
+ ;; If x < y, need to move y to r, otherwise r already has
+ ;; the max.
+ (inst cmove :l r y :fcc0))
+ ((location= r y)
+ ;; If x > y, need to move x to r, otherwise r already has
+ ;; the max.
+ (inst cmove :ge r x :fcc0))
+ (t
+ ;; It doesn't matter what R is, just copy the min to R.
+ (inst cmove :ge r x :fcc0)
+ (inst cmove :l r y :fcc0))))))
+
) ; PROGN
#+nil
;;; The sparc-v9 architecture has conditional move instructions that
;;; can be used. This should be faster than using the obvious if
;;; expression since we don't have to do branches.
-
+
(define-source-transform min (&rest args)
(if (member :sparc-v9 *backend-subfeatures*)
(case (length args)
- ((0 2) (values nil t))
- (1 `(values ,(first args)))
- (t (sb!c::associate-arguments 'min (first args) (rest args))))
+ ((0 2) (values nil t))
+ (1 `(values ,(first args)))
+ (t (sb!c::associate-arguments 'min (first args) (rest args))))
(values nil t)))
(define-source-transform max (&rest args)
(if (member :sparc-v9 *backend-subfeatures*)
(case (length args)
- ((0 2) (values nil t))
- (1 `(values ,(first args)))
- (t (sb!c::associate-arguments 'max (first args) (rest args))))
+ ((0 2) (values nil t))
+ (1 `(values ,(first args)))
+ (t (sb!c::associate-arguments 'max (first args) (rest args))))
(values nil t)))
;; Derive the types of max and min
(multiple-value-bind (definitely-< definitely->=)
(ir1-transform-<-helper x y)
(cond (definitely-<
- (lvar-type y))
- (definitely->=
- (lvar-type x))
- (t
- (make-canonical-union-type (list (lvar-type x)
- (lvar-type y)))))))
+ (lvar-type y))
+ (definitely->=
+ (lvar-type x))
+ (t
+ (make-canonical-union-type (list (lvar-type x)
+ (lvar-type y)))))))
(defoptimizer (min derive-type) ((x y))
(multiple-value-bind (definitely-> definitely-<=)
(ir1-transform-<-helper y x)
(cond (definitely-<=
- (lvar-type x))
- (definitely->
- (lvar-type y))
- (t
- (make-canonical-union-type (list (lvar-type x)
- (lvar-type y)))))))
+ (lvar-type x))
+ (definitely->
+ (lvar-type y))
+ (t
+ (make-canonical-union-type (list (lvar-type x)
+ (lvar-type y)))))))
(deftransform max ((x y) (number number) *)
(let ((x-type (lvar-type x))
- (y-type (lvar-type y))
- (signed (specifier-type '(signed-byte #.n-word-bits)))
- (unsigned (specifier-type '(unsigned-byte #.n-word-bits)))
- (d-float (specifier-type 'double-float))
- (s-float (specifier-type 'single-float)))
+ (y-type (lvar-type y))
+ (signed (specifier-type '(signed-byte #.n-word-bits)))
+ (unsigned (specifier-type '(unsigned-byte #.n-word-bits)))
+ (d-float (specifier-type 'double-float))
+ (s-float (specifier-type 'single-float)))
;; Use %%max if both args are good types of the same type. As a
;; last resort, use the obvious comparison to select the desired
;; element.
(cond ((and (csubtypep x-type signed)
- (csubtypep y-type signed))
- `(%%max x y))
- ((and (csubtypep x-type unsigned)
- (csubtypep y-type unsigned))
- `(%%max x y))
- ((and (csubtypep x-type d-float)
- (csubtypep y-type d-float))
- `(%%max x y))
- ((and (csubtypep x-type s-float)
- (csubtypep y-type s-float))
- `(%%max x y))
- (t
- (let ((arg1 (gensym))
- (arg2 (gensym)))
- `(let ((,arg1 x)
- (,arg2 y))
- (if (>= ,arg1 ,arg2)
- ,arg1 ,arg2)))))))
+ (csubtypep y-type signed))
+ `(%%max x y))
+ ((and (csubtypep x-type unsigned)
+ (csubtypep y-type unsigned))
+ `(%%max x y))
+ ((and (csubtypep x-type d-float)
+ (csubtypep y-type d-float))
+ `(%%max x y))
+ ((and (csubtypep x-type s-float)
+ (csubtypep y-type s-float))
+ `(%%max x y))
+ (t
+ (let ((arg1 (gensym))
+ (arg2 (gensym)))
+ `(let ((,arg1 x)
+ (,arg2 y))
+ (if (>= ,arg1 ,arg2)
+ ,arg1 ,arg2)))))))
(deftransform min ((x y) (real real) *)
(let ((x-type (lvar-type x))
- (y-type (lvar-type y))
- (signed (specifier-type '(signed-byte #.n-word-bits)))
- (unsigned (specifier-type '(unsigned-byte #.n-word-bits)))
- (d-float (specifier-type 'double-float))
- (s-float (specifier-type 'single-float)))
+ (y-type (lvar-type y))
+ (signed (specifier-type '(signed-byte #.n-word-bits)))
+ (unsigned (specifier-type '(unsigned-byte #.n-word-bits)))
+ (d-float (specifier-type 'double-float))
+ (s-float (specifier-type 'single-float)))
(cond ((and (csubtypep x-type signed)
- (csubtypep y-type signed))
- `(%%min x y))
- ((and (csubtypep x-type unsigned)
- (csubtypep y-type unsigned))
- `(%%min x y))
- ((and (csubtypep x-type d-float)
- (csubtypep y-type d-float))
- `(%%min x y))
- ((and (csubtypep x-type s-float)
- (csubtypep y-type s-float))
- `(%%min x y))
- (t
- (let ((arg1 (gensym))
- (arg2 (gensym)))
- `(let ((,arg1 x)
- (,arg2 y))
- (if (<= ,arg1 ,arg2)
- ,arg1 ,arg2)))))))
+ (csubtypep y-type signed))
+ `(%%min x y))
+ ((and (csubtypep x-type unsigned)
+ (csubtypep y-type unsigned))
+ `(%%min x y))
+ ((and (csubtypep x-type d-float)
+ (csubtypep y-type d-float))
+ `(%%min x y))
+ ((and (csubtypep x-type s-float)
+ (csubtypep y-type s-float))
+ `(%%min x y))
+ (t
+ (let ((arg1 (gensym))
+ (arg2 (gensym)))
+ `(let ((,arg1 x)
+ (,arg2 y))
+ (if (<= ,arg1 ,arg2)
+ ,arg1 ,arg2)))))))
) ; PROGN
(null null-offset)
(t
(if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
- (tn-offset tn)
- (error "~S isn't a register." tn)))))
+ (tn-offset tn)
+ (error "~S isn't a register." tn)))))
(defun fp-reg-tn-encoding (tn)
(declare (type tn tn))
(error "~S isn't a floating-point register." tn))
(let ((offset (tn-offset tn)))
(cond ((> offset 31)
- (aver (member :sparc-v9 *backend-subfeatures*))
- ;; No single register encoding greater than reg 31.
- (aver (zerop (mod offset 2)))
- ;; Upper bit of the register number is encoded in the low bit.
- (1+ (- offset 32)))
- (t
- (tn-offset tn)))))
+ (aver (member :sparc-v9 *backend-subfeatures*))
+ ;; No single register encoding greater than reg 31.
+ (aver (zerop (mod offset 2)))
+ ;; Upper bit of the register number is encoded in the low bit.
+ (1+ (- offset 32)))
+ (t
+ (tn-offset tn)))))
;;;(sb!disassem:set-disassem-params :instruction-alignment 32
-;;; :opcode-column-width 11)
+;;; :opcode-column-width 11)
(defvar *disassem-use-lisp-reg-names* t
#!+sb-doc
(tn
(ecase (sb-name (sc-sb (tn-sc loc)))
(registers
- (unless (zerop (tn-offset loc))
- (tn-offset loc)))
+ (unless (zerop (tn-offset loc))
+ (tn-offset loc)))
(float-registers
- (sc-case loc
- (single-reg
- (+ (tn-offset loc) 32))
- (double-reg
- (let ((offset (tn-offset loc)))
- (aver (zerop (mod offset 2)))
- (values (+ offset 32) 2)))
- #!+long-float
- (long-reg
- (let ((offset (tn-offset loc)))
- (aver (zerop (mod offset 4)))
- (values (+ offset 32) 4)))))
+ (sc-case loc
+ (single-reg
+ (+ (tn-offset loc) 32))
+ (double-reg
+ (let ((offset (tn-offset loc)))
+ (aver (zerop (mod offset 2)))
+ (values (+ offset 32) 2)))
+ #!+long-float
+ (long-reg
+ (let ((offset (tn-offset loc)))
+ (aver (zerop (mod offset 4)))
+ (values (+ offset 32) 4)))))
(control-registers
- 96)
+ 96)
(immediate-constant
- nil)))
+ nil)))
(symbol
(ecase loc
(:memory 0)
(defparameter reg-symbols
(map 'vector
(lambda (name)
- (cond ((null name) nil)
- (t (make-symbol (concatenate 'string "%" name)))))
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "%" name)))))
*register-names*)
#!+sb-doc "The Lisp names for the Sparc integer registers")
"%L0" "%L1" "%L2" "%L3" "%L4" "%L5" "%L6" "%L7"
"%I0" "%I1" "%I2" "%I3" "%I4" "%I5" NIL "%I7")
#!+sb-doc "The standard names for the Sparc integer registers")
-
+
(defun get-reg-name (index)
(if *disassem-use-lisp-reg-names*
(aref reg-symbols index)
(defun maybe-add-notes (reg dstate)
(let* ((word (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
- (sb!disassem::dstate-cur-offs dstate)
- n-word-bytes
- (sb!disassem::dstate-byte-order dstate)))
- (format (ldb (byte 2 30) word))
- (op3 (ldb (byte 6 19) word))
- (rs1 (ldb (byte 5 14) word))
- (rd (ldb (byte 5 25) word))
- (immed-p (not (zerop (ldb (byte 1 13) word))))
- (immed-val (sign-extend-immed-value (ldb (byte 13 0) word))))
+ (sb!disassem::dstate-cur-offs dstate)
+ n-word-bytes
+ (sb!disassem::dstate-byte-order dstate)))
+ (format (ldb (byte 2 30) word))
+ (op3 (ldb (byte 6 19) word))
+ (rs1 (ldb (byte 5 14) word))
+ (rd (ldb (byte 5 25) word))
+ (immed-p (not (zerop (ldb (byte 1 13) word))))
+ (immed-val (sign-extend-immed-value (ldb (byte 13 0) word))))
(declare (ignore immed-p))
;; Only the value of format and rd are guaranteed to be correct
;; because the disassembler is trying to print out the value of a
(case format
(2
(case op3
- (#b000000
- (when (= reg rs1)
- (handle-add-inst rs1 immed-val rd dstate)))
- (#b111000
- (when (= reg rs1)
- (handle-jmpl-inst rs1 immed-val rd dstate)))
- (#b010001
- (when (= reg rs1)
- (handle-andcc-inst rs1 immed-val rd dstate)))))
+ (#b000000
+ (when (= reg rs1)
+ (handle-add-inst rs1 immed-val rd dstate)))
+ (#b111000
+ (when (= reg rs1)
+ (handle-jmpl-inst rs1 immed-val rd dstate)))
+ (#b010001
+ (when (= reg rs1)
+ (handle-andcc-inst rs1 immed-val rd dstate)))))
(3
(case op3
- ((#b000000 #b000100)
- (when (= reg rs1)
- (handle-ld/st-inst rs1 immed-val rd dstate))))))
+ ((#b000000 #b000100)
+ (when (= reg rs1)
+ (handle-ld/st-inst rs1 immed-val rd dstate))))))
;; If this is not a SETHI instruction, and RD is the same as some
;; register used by SETHI, we delete the entry. (In case we have
;; a SETHI without any additional instruction because the low bits
;; were zero.)
(unless (and (zerop format) (= #b100 (ldb (byte 3 22) word)))
(let ((sethi (assoc rd *note-sethi-inst*)))
- (when sethi
- (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))))))
+ (when sethi
+ (setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))))))
(defun handle-add-inst (rs1 immed-val rd dstate)
(let* ((sethi (assoc rs1 *note-sethi-inst*)))
;; foreign routine, if possible. If not, just note the
;; final value.
(let ((addr (+ immed-val (ash (cdr sethi) 10))))
- (or (sb!disassem::note-code-constant-absolute addr dstate)
- (sb!disassem:maybe-note-assembler-routine addr t dstate)
- (sb!disassem:note (format nil "~A = #x~8,'0X"
- (get-reg-name rd) addr)
- dstate)))
+ (or (sb!disassem::note-code-constant-absolute addr dstate)
+ (sb!disassem:maybe-note-assembler-routine addr t dstate)
+ (sb!disassem:note (format nil "~A = #x~8,'0X"
+ (get-reg-name rd) addr)
+ dstate)))
(setf *note-sethi-inst* (delete sethi *note-sethi-inst*)))
((= rs1 null-offset)
;; We have an ADD %NULL, <n>, RD instruction. This is a
;; reference to a static symbol.
(sb!disassem:maybe-note-nil-indexed-object immed-val
- dstate))
+ dstate))
((= rs1 alloc-offset)
;; ADD %ALLOC, n. This must be some allocation or
;; pseudo-atomic stuff
(cond ((and (= immed-val 4) (= rd alloc-offset)
- (not *pseudo-atomic-set*))
- ;; "ADD 4, %ALLOC" sets the flag
- (sb!disassem::note "Set pseudo-atomic flag" dstate)
- (setf *pseudo-atomic-set* t))
- ((= rd alloc-offset)
- ;; "ADD n, %ALLOC" is reseting the flag, with extra
- ;; allocation.
- (sb!disassem:note
- (format nil "Reset pseudo-atomic, allocated ~D bytes"
- (+ immed-val 4)) dstate)
- (setf *pseudo-atomic-set* nil))))
+ (not *pseudo-atomic-set*))
+ ;; "ADD 4, %ALLOC" sets the flag
+ (sb!disassem::note "Set pseudo-atomic flag" dstate)
+ (setf *pseudo-atomic-set* t))
+ ((= rd alloc-offset)
+ ;; "ADD n, %ALLOC" is reseting the flag, with extra
+ ;; allocation.
+ (sb!disassem:note
+ (format nil "Reset pseudo-atomic, allocated ~D bytes"
+ (+ immed-val 4)) dstate)
+ (setf *pseudo-atomic-set* nil))))
#+nil ((and (= rs1 zero-offset) *pseudo-atomic-set*)
;; "ADD %ZERO, num, RD" inside a pseudo-atomic is very
;; likely loading up a header word. Make a note to that
;; effect.
(let ((type (second (assoc (logand immed-val #xff) header-word-type-alist)))
- (size (ldb (byte 24 8) immed-val)))
- (when type
- (sb!disassem:note (format nil "Header word ~A, size ~D?" type size)
- dstate)))))))
+ (size (ldb (byte 24 8) immed-val)))
+ (when type
+ (sb!disassem:note (format nil "Header word ~A, size ~D?" type size)
+ dstate)))))))
(defun handle-jmpl-inst (rs1 immed-val rd dstate)
(declare (ignore rd))
;; foreign routine, if possible. If not, just note the
;; final value.
(let ((addr (+ immed-val (ash (cdr sethi) 10))))
- (sb!disassem:maybe-note-assembler-routine addr t dstate)
- (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))
+ (sb!disassem:maybe-note-assembler-routine addr t dstate)
+ (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))
(defun handle-ld/st-inst (rs1 immed-val rd dstate)
(declare (ignore rd))
;; A reference to a static symbol or static function (reg =
;; %NULL)
(or (sb!disassem:maybe-note-nil-indexed-symbol-slot-ref immed-val
- dstate)
- #+nil (sb!disassem::maybe-note-static-function immed-val dstate)))
+ dstate)
+ #+nil (sb!disassem::maybe-note-static-function immed-val dstate)))
(t
(let ((sethi (assoc rs1 *note-sethi-inst*)))
(when sethi
- (let ((addr (+ immed-val (ash (cdr sethi) 10))))
- (sb!disassem:maybe-note-assembler-routine addr nil dstate)
- (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))))
+ (let ((addr (+ immed-val (ash (cdr sethi) 10))))
+ (sb!disassem:maybe-note-assembler-routine addr nil dstate)
+ (setf *note-sethi-inst* (delete sethi *note-sethi-inst*))))))))
(defun handle-andcc-inst (rs1 immed-val rd dstate)
;; ANDCC %ALLOC, 3, %ZERO instruction
(when (and (= rs1 alloc-offset) (= rd zero-offset) (= immed-val 3))
(sb!disassem:note "pseudo-atomic interrupted?" dstate)))
-
+
(sb!disassem:define-arg-type reg
:printer (lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (get-reg-name value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref value
- 'registers
- regname
- dstate)
- (maybe-add-notes value dstate))))
+ (declare (stream stream) (fixnum value))
+ (let ((regname (get-reg-name value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref value
+ 'registers
+ regname
+ dstate)
+ (maybe-add-notes value dstate))))
(defparameter float-reg-symbols
- #.(coerce
+ #.(coerce
(loop for n from 0 to 63 collect (make-symbol (format nil "%F~d" n)))
'vector))
(sb!disassem:define-arg-type fp-reg
:printer (lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref float-reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'float-registers
- regname
- dstate))))
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref float-reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'float-registers
+ regname
+ dstate))))
;;; The extended 6 bit floating point register encoding for the double
;;; and long instructions of the sparc v9.
(sb!disassem:define-arg-type fp-ext-reg
:printer (lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let* (;; Decode the register number.
- (value (if (oddp value) (+ value 31) value))
- (regname (aref float-reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'float-registers
- regname
- dstate))))
+ (declare (stream stream) (fixnum value))
+ (let* (;; Decode the register number.
+ (value (if (oddp value) (+ value 31) value))
+ (regname (aref float-reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'float-registers
+ regname
+ dstate))))
(sb!disassem:define-arg-type relative-label
:sign-extend t
:use-label (lambda (value dstate)
- (declare (type (signed-byte 22) value)
- (type sb!disassem:disassem-state dstate))
- (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
+ (declare (type (signed-byte 22) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
(defconstant-eqx branch-conditions
'(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)
(defun branch-condition (condition)
(or (position condition branch-conditions)
(error "Unknown branch condition: ~S~%Must be one of: ~S"
- condition branch-conditions)))
+ condition branch-conditions)))
(def!constant branch-cond-true
#b1000)
(defun fp-branch-condition (condition)
(or (position condition branch-fp-conditions)
(error "Unknown fp-branch condition: ~S~%Must be one of: ~S"
- condition branch-fp-conditions)))
+ condition branch-fp-conditions)))
\f
;;;; dissassem:define-instruction-formats
(op2 :field (byte 3 22))
(immed :field (byte 22 0)))
-
+
(sb!disassem:define-instruction-format
(format-2-branch 32 :default-printer `(:name (:unless (:constant ,branch-cond-true) cond)
- (:unless (a :constant 0) "," 'A)
- :tab
- disp))
+ (:unless (a :constant 0) "," 'A)
+ :tab
+ disp))
(op :field (byte 2 30) :value 0)
(a :field (byte 1 29) :value 0)
(cond :field (byte 4 25) :type 'branch-condition)
(defparameter integer-condition-reg-symbols
(map 'vector
(lambda (name)
- (make-symbol (concatenate 'string "%" (string name))))
+ (make-symbol (concatenate 'string "%" (string name))))
integer-condition-registers))
(sb!disassem:define-arg-type integer-condition-register
:printer (lambda (value stream dstate)
- (declare (stream stream) (fixnum value) (ignore dstate))
- (let ((regname (aref integer-condition-reg-symbols value)))
- (princ regname stream))))
+ (declare (stream stream) (fixnum value) (ignore dstate))
+ (let ((regname (aref integer-condition-reg-symbols value)))
+ (princ regname stream))))
(defconstant-eqx branch-predictions
'(:pn :pt)
(declare (type (member :icc :xcc) condition-reg))
(or (position condition-reg integer-condition-registers)
(error "Unknown integer condition register: ~S~%"
- condition-reg)))
+ condition-reg)))
(defun branch-prediction (pred)
(or (position pred branch-predictions)
(error "Unknown branch prediction: ~S~%Must be one of: ~S~%"
- pred branch-predictions)))
+ pred branch-predictions)))
(defconstant-eqx branch-pred-printer
`(:name (:unless (:constant ,branch-cond-true) cond)
- (:unless (a :constant 0) "," 'A)
+ (:unless (a :constant 0) "," 'A)
(:unless (p :constant 1) "," 'pn)
- :tab
- cc
- ", "
- disp)
+ :tab
+ cc
+ ", "
+ disp)
#'equalp)
(sb!disassem:define-instruction-format
(defparameter fp-condition-reg-symbols
(map 'vector
(lambda (name)
- (make-symbol (concatenate 'string "%" (string name))))
+ (make-symbol (concatenate 'string "%" (string name))))
fp-condition-registers))
(sb!disassem:define-arg-type fp-condition-register
:printer (lambda (value stream dstate)
- (declare (stream stream) (fixnum value) (ignore dstate))
- (let ((regname (aref fp-condition-reg-symbols value)))
- (princ regname stream))))
+ (declare (stream stream) (fixnum value) (ignore dstate))
+ (let ((regname (aref fp-condition-reg-symbols value)))
+ (princ regname stream))))
(sb!disassem:define-arg-type fp-condition-register-shifted
:printer (lambda (value stream dstate)
- (declare (stream stream) (fixnum value) (ignore dstate))
- (let ((regname (aref fp-condition-reg-symbols (ash value -1))))
- (princ regname stream))))
+ (declare (stream stream) (fixnum value) (ignore dstate))
+ (let ((regname (aref fp-condition-reg-symbols (ash value -1))))
+ (princ regname stream))))
(defun fp-condition (condition-reg)
(or (position condition-reg fp-condition-registers)
(error "Unknown integer condition register: ~S~%"
- condition-reg)))
+ condition-reg)))
(defconstant-eqx fp-branch-pred-printer
`(:name (:unless (:constant ,branch-cond-true) cond)
- (:unless (a :constant 0) "," 'A)
- (:unless (p :constant 1) "," 'pn)
- :tab
- fcc
- ", "
- disp)
+ (:unless (a :constant 0) "," 'A)
+ (:unless (p :constant 1) "," 'pn)
+ :tab
+ fcc
+ ", "
+ disp)
#'equalp)
(sb!disassem:define-instruction-format
(fcc :field (byte 2 20) :type 'fp-condition-register)
(p :field (byte 1 19))
(disp :field (byte 19 0) :type 'relative-label))
-
+
(sb!disassem:define-instruction-format
(defconstant-eqx f3-printer
'(:name :tab
- (:unless (:same-as rd) rs1 ", ")
- (:choose rs2 immed) ", "
- rd)
+ (:unless (:same-as rd) rs1 ", ")
+ (:choose rs2 immed) ", "
+ rd)
#'equalp)
(sb!disassem:define-instruction-format
(op3 :field (byte 6 19))
(rs1 :field (byte 5 14) :type 'reg)
(i :field (byte 1 13) :value 1)
- (immed :field (byte 13 0) :sign-extend t)) ; usually sign extended
+ (immed :field (byte 13 0) :sign-extend t)) ; usually sign extended
(sb!disassem:define-instruction-format
(format-binary-fpop 32
:default-printer '(:name :tab rs1 ", " rs2 ", " rd))
- (op :field (byte 2 30))
- (rd :field (byte 5 25) :type 'fp-reg)
+ (op :field (byte 2 30))
+ (rd :field (byte 5 25) :type 'fp-reg)
(op3 :field (byte 6 19))
(rs1 :field (byte 5 14) :type 'fp-reg)
(opf :field (byte 9 5))
;;; Floating point load/save instructions encoding.
(sb!disassem:define-instruction-format
(format-unary-fpop 32 :default-printer '(:name :tab rs2 ", " rd))
- (op :field (byte 2 30))
- (rd :field (byte 5 25) :type 'fp-reg)
+ (op :field (byte 2 30))
+ (rd :field (byte 5 25) :type 'fp-reg)
(op3 :field (byte 6 19))
(rs1 :field (byte 5 14) :value 0)
(opf :field (byte 9 5))
;;
;; Bit 1 0
;; 3 5
-;; FMOVcc 0nn0000xx %fccn
-;; 1000000xx %icc
-;; 1100000xx %xcc
-;; FMOVR 0ccc001yy
-;; FCMP 001010zzz
+;; FMOVcc 0nn0000xx %fccn
+;; 1000000xx %icc
+;; 1100000xx %xcc
+;; FMOVR 0ccc001yy
+;; FCMP 001010zzz
;;
;; So we see that if we break up the OPF field into 4 pieces, opf0,
;; opf1, opf2, and opf3, we can distinguish between these
;;
(sb!disassem:define-instruction-format
(format-fpop2 32
- :default-printer #!-sparc-v9 '(:name :tab rs1 ", " rs2)
- #!+sparc-v9 '(:name :tab rd ", " rs1 ", " rs2))
- (op :field (byte 2 30))
- (rd :field (byte 5 25) :value 0)
+ :default-printer #!-sparc-v9 '(:name :tab rs1 ", " rs2)
+ #!+sparc-v9 '(:name :tab rd ", " rs1 ", " rs2))
+ (op :field (byte 2 30))
+ (rd :field (byte 5 25) :value 0)
(op3 :field (byte 6 19))
(rs1 :field (byte 5 14))
(opf0 :field (byte 1 13))
;;; Shift instructions
(sb!disassem:define-instruction-format
(format-3-shift-reg 32 :default-printer f3-printer)
- (op :field (byte 2 30))
+ (op :field (byte 2 30))
(rd :field (byte 5 25) :type 'reg)
(op3 :field (byte 6 19))
(rs1 :field (byte 5 14) :type 'reg)
(sb!disassem:define-instruction-format
(format-3-shift-immed 32 :default-printer f3-printer)
- (op :field (byte 2 30))
+ (op :field (byte 2 30))
(rd :field (byte 5 25) :type 'reg)
(op3 :field (byte 6 19))
(rs1 :field (byte 5 14) :type 'reg)
(defparameter cond-move-condition-reg-symbols
(map 'vector
(lambda (name)
- (make-symbol (concatenate 'string "%" (string name))))
+ (make-symbol (concatenate 'string "%" (string name))))
cond-move-condition-registers))
(sb!disassem:define-arg-type cond-move-condition-register
:printer (lambda (value stream dstate)
- (declare (stream stream) (fixnum value) (ignore dstate))
- (let ((regname (aref cond-move-condition-reg-symbols value)))
- (princ regname stream))))
+ (declare (stream stream) (fixnum value) (ignore dstate))
+ (let ((regname (aref cond-move-condition-reg-symbols value)))
+ (princ regname stream))))
;; From the given condition register, figure out what the cc2, cc1,
;; and cc0 bits should be. Return cc2 and cc1/cc0 concatenated.
(defun cond-move-condition-parts (condition-reg)
(let ((posn (position condition-reg cond-move-condition-registers)))
(if posn
- (truncate posn 4)
- (error "Unknown conditional move condition register: ~S~%"
- condition-reg))))
+ (truncate posn 4)
+ (error "Unknown conditional move condition register: ~S~%"
+ condition-reg))))
(defun cond-move-condition (condition-reg)
(or (position condition-reg cond-move-condition-registers)
;; Conditional move integer register on integer or FP condition code
(sb!disassem:define-instruction-format
(format-4-cond-move 32 :default-printer cond-move-printer)
- (op :field (byte 2 30))
+ (op :field (byte 2 30))
(rd :field (byte 5 25) :type 'reg)
(op3 :field (byte 6 19))
(cc2 :field (byte 1 18) :value 1)
(sb!disassem:define-arg-type register-condition
:printer (lambda (value stream dstate)
- (declare (stream stream) (fixnum value) (ignore dstate))
- (let ((regname (aref cond-move-integer-condition-vec value)))
- (princ regname stream))))
+ (declare (stream stream) (fixnum value) (ignore dstate))
+ (let ((regname (aref cond-move-integer-condition-vec value)))
+ (princ regname stream))))
(defconstant-eqx cond-move-integer-printer
`(:name rcond :tab rs1 ", " (:choose immed rs2) ", " rd)
(rs1 :field (byte 5 14) :type 'reg)
(i :field (byte 1 13) :value 1)
(cc :field (byte 2 11) :type 'integer-condition-register)
- (immed :field (byte 11 0) :sign-extend t)) ; usually sign extended
+ (immed :field (byte 11 0) :sign-extend t)) ; usually sign extended
(defconstant-eqx cond-fp-move-integer-printer
(byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))
(define-bitfield-emitter emit-format-2-fp-branch-pred 32
(byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 2 20) (byte 1 19) (byte 19 0))
-
+
(define-bitfield-emitter emit-format-2-unimp 32
(byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
(define-bitfield-emitter emit-format-4-trap 32
(byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 2 11)
(byte 11 0))
-
+
\f
;;;; Most of the format-3-instructions.
(defun emit-format-3-inst (segment op op3 dst src1 src2
- &key load-store fixup dest-kind)
+ &key load-store fixup dest-kind)
(unless src2
(cond ((and (typep src1 'tn) load-store)
- (setf src2 0))
- (t
- (setf src2 src1)
- (setf src1 dst))))
+ (setf src2 0))
+ (t
+ (setf src2 src1)
+ (setf src1 dst))))
(etypecase src2
(tn
(emit-format-3-reg segment op
- (if dest-kind
- (fp-reg-tn-encoding dst)
- (reg-tn-encoding dst))
- op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2)))
+ (if dest-kind
+ (fp-reg-tn-encoding dst)
+ (reg-tn-encoding dst))
+ op3 (reg-tn-encoding src1) 0 0 (reg-tn-encoding src2)))
(integer
(emit-format-3-immed segment op
- (if dest-kind
- (fp-reg-tn-encoding dst)
- (reg-tn-encoding dst))
- op3 (reg-tn-encoding src1) 1 src2))
+ (if dest-kind
+ (fp-reg-tn-encoding dst)
+ (reg-tn-encoding dst))
+ op3 (reg-tn-encoding src1) 1 src2))
(fixup
(unless (or load-store fixup)
(error "Fixups aren't allowed."))
(note-fixup segment :add src2)
(emit-format-3-immed segment op
- (if dest-kind
- (fp-reg-tn-encoding dst)
- (reg-tn-encoding dst))
- op3 (reg-tn-encoding src1) 1 0))))
+ (if dest-kind
+ (fp-reg-tn-encoding dst)
+ (reg-tn-encoding dst))
+ op3 (reg-tn-encoding src1) 1 0))))
;;; Shift instructions because an extra bit is used in Sparc V9's to
;;; indicate whether the shift is a 32-bit or 64-bit shift.
(etypecase src2
(tn
(emit-format-3-shift-reg segment op (reg-tn-encoding dst)
- op3 (reg-tn-encoding src1) 0 (if extended 1 0)
- 0 (reg-tn-encoding src2)))
+ op3 (reg-tn-encoding src1) 0 (if extended 1 0)
+ 0 (reg-tn-encoding src2)))
(integer
(emit-format-3-shift-immed segment op (reg-tn-encoding dst)
- op3 (reg-tn-encoding src1) 1
- (if extended 1 0) src2))))
+ op3 (reg-tn-encoding src1) 1
+ (if extended 1 0) src2))))
(eval-when (:compile-toplevel :execute)
;;; have to do this because def!constant is evalutated in the null lex env.
(defmacro with-ref-format (printer)
`(let* ((addend
- '(:choose (:plus-integer immed) ("+" rs2)))
- (ref-format
- `("[" rs1 (:unless (:constant 0) ,addend) "]"
- (:choose (:unless (:constant 0) asi) nil))))
+ '(:choose (:plus-integer immed) ("+" rs2)))
+ (ref-format
+ `("[" rs1 (:unless (:constant 0) ,addend) "]"
+ (:choose (:unless (:constant 0) asi) nil))))
,printer))
(defconstant-eqx load-printer
) ; EVAL-WHEN
(macrolet ((define-f3-inst (name op op3 &key fixup load-store (dest-kind 'reg)
- (printer :default) reads writes flushable print-name)
+ (printer :default) reads writes flushable print-name)
(let ((printer
- (if (eq printer :default)
- (case load-store
- ((nil) :default)
- ((:load t) 'load-printer)
- (:store 'store-printer))
- printer)))
+ (if (eq printer :default)
+ (case load-store
+ ((nil) :default)
+ ((:load t) 'load-printer)
+ (:store 'store-printer))
+ printer)))
(when (and (atom reads) (not (null reads)))
(setf reads (list reads)))
(when (and (atom writes) (not (null writes)))
(setf writes (list writes)))
`(define-instruction ,name (segment dst src1 &optional src2)
(:declare (type tn dst)
- ,(if (or fixup load-store)
- '(type (or tn (signed-byte 13) null fixup) src1 src2)
- '(type (or tn (signed-byte 13) null) src1 src2)))
+ ,(if (or fixup load-store)
+ '(type (or tn (signed-byte 13) null fixup) src1 src2)
+ '(type (or tn (signed-byte 13) null) src1 src2)))
(:printer format-3-reg
- ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
- ,printer
- ,@(when print-name `(:print-name ,print-name)))
+ ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
+ ,printer
+ ,@(when print-name `(:print-name ,print-name)))
(:printer format-3-immed
- ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
- ,printer
- ,@(when print-name `(:print-name ,print-name)))
+ ((op ,op) (op3 ,op3) (rd nil :type ',dest-kind))
+ ,printer
+ ,@(when print-name `(:print-name ,print-name)))
,@(when flushable
- '((:attributes flushable)))
+ '((:attributes flushable)))
(:dependencies
- (reads src1)
- ,@(let ((reads-list nil))
- (dolist (read reads)
- (push (list 'reads read) reads-list))
- reads-list)
- ,@(cond ((eq load-store :store)
- '((reads dst)
- (if src2 (reads src2))))
- ((eq load-store t)
- '((reads :memory)
- (reads dst)
- (if src2 (reads src2))))
- ((eq load-store :load)
- '((reads :memory)
- (if src2 (reads src2) (reads dst))))
- (t
- '((if src2 (reads src2) (reads dst)))))
- ,@(let ((writes-list nil))
- (dolist (write writes)
- (push (list 'writes write) writes-list))
- writes-list)
- ,@(cond ((eq load-store :store)
- '((writes :memory :partially t)))
- ((eq load-store t)
- '((writes :memory :partially t)
- (writes dst)))
- ((eq load-store :load)
- '((writes dst)))
- (t
- '((writes dst)))))
+ (reads src1)
+ ,@(let ((reads-list nil))
+ (dolist (read reads)
+ (push (list 'reads read) reads-list))
+ reads-list)
+ ,@(cond ((eq load-store :store)
+ '((reads dst)
+ (if src2 (reads src2))))
+ ((eq load-store t)
+ '((reads :memory)
+ (reads dst)
+ (if src2 (reads src2))))
+ ((eq load-store :load)
+ '((reads :memory)
+ (if src2 (reads src2) (reads dst))))
+ (t
+ '((if src2 (reads src2) (reads dst)))))
+ ,@(let ((writes-list nil))
+ (dolist (write writes)
+ (push (list 'writes write) writes-list))
+ writes-list)
+ ,@(cond ((eq load-store :store)
+ '((writes :memory :partially t)))
+ ((eq load-store t)
+ '((writes :memory :partially t)
+ (writes dst)))
+ ((eq load-store :load)
+ '((writes dst)))
+ (t
+ '((writes dst)))))
(:delay 0)
(:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2
- :load-store ,load-store
- :fixup ,fixup
- :dest-kind (not (eq ',dest-kind 'reg)))))))
-
- (define-f3-shift-inst (name op op3 &key extended)
- `(define-instruction ,name (segment dst src1 &optional src2)
- (:declare (type tn dst)
- (type (or tn (unsigned-byte 6) null) src1 src2))
- (:printer format-3-shift-reg
- ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 0)))
- (:printer format-3-shift-immed
- ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 1)))
- (:dependencies
- (reads src1)
- (if src2 (reads src2) (reads dst))
- (writes dst))
- (:delay 0)
- (:emitter (emit-format-3-shift-inst segment ,op ,op3 dst src1 src2
- :extended ,extended)))))
+ :load-store ,load-store
+ :fixup ,fixup
+ :dest-kind (not (eq ',dest-kind 'reg)))))))
+
+ (define-f3-shift-inst (name op op3 &key extended)
+ `(define-instruction ,name (segment dst src1 &optional src2)
+ (:declare (type tn dst)
+ (type (or tn (unsigned-byte 6) null) src1 src2))
+ (:printer format-3-shift-reg
+ ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 0)))
+ (:printer format-3-shift-immed
+ ((op ,op) (op3 ,op3) (x ,(if extended 1 0)) (i 1)))
+ (:dependencies
+ (reads src1)
+ (if src2 (reads src2) (reads dst))
+ (writes dst))
+ (:delay 0)
+ (:emitter (emit-format-3-shift-inst segment ,op ,op3 dst src1 src2
+ :extended ,extended)))))
(define-f3-inst ldsb #b11 #b001001 :load-store :load)
(define-f3-inst ldsh #b11 #b001010 :load-store :load)
;; This instruction is called lduw for V9 , but looks exactly like ld
;; on previous architectures.
(define-f3-inst ld #b11 #b000000 :load-store :load
- #!+sparc-v9 :print-name #!+sparc-v9 'lduw)
+ #!+sparc-v9 :print-name #!+sparc-v9 'lduw)
(define-f3-inst ldsw #b11 #b001000 :load-store :load) ; v9
-
+
;; ldd is deprecated on the Sparc V9.
(define-f3-inst ldd #b11 #b000011 :load-store :load)
-
+
(define-f3-inst ldx #b11 #b001011 :load-store :load) ; v9
-
+
(define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
(define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load)
- (define-f3-inst ldqf #b11 #b100010 :dest-kind fp-reg :load-store :load) ; v9
+ (define-f3-inst ldqf #b11 #b100010 :dest-kind fp-reg :load-store :load) ; v9
(define-f3-inst stb #b11 #b000101 :load-store :store)
(define-f3-inst sth #b11 #b000110 :load-store :store)
(define-f3-inst st #b11 #b000100 :load-store :store)
-
+
;; std is deprecated on the Sparc V9.
(define-f3-inst std #b11 #b000111 :load-store :store)
-
+
(define-f3-inst stx #b11 #b001110 :load-store :store) ; v9
-
+
(define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
(define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store)
(define-f3-inst stqf #b11 #b100110 :dest-kind fp-reg :load-store :store) ; v9
(define-f3-inst ldstub #b11 #b001101 :load-store t)
-
+
;; swap is deprecated on the Sparc V9
(define-f3-inst swap #b11 #b001111 :load-store t)
-
+
(define-f3-inst add #b10 #b000000 :fixup t)
(define-f3-inst addcc #b10 #b010000 :writes :psr)
(define-f3-inst addx #b10 #b001000 :reads :psr)
(define-f3-inst addxcc #b10 #b011000 :reads :psr :writes :psr)
(define-f3-inst taddcc #b10 #b100000 :writes :psr)
-
+
;; taddcctv is deprecated on the Sparc V9. Use taddcc and bpvs or
;; taddcc and trap to get a similar effect. (Requires changing the C
;; code though!)
(define-f3-inst xorcc #b10 #b010011 :writes :psr)
(define-f3-inst xnor #b10 #b000111)
(define-f3-inst xnorcc #b10 #b010111 :writes :psr)
-
+
(define-f3-shift-inst sll #b10 #b100101)
(define-f3-shift-inst srl #b10 #b100110)
(define-f3-shift-inst sra #b10 #b100111)
- (define-f3-shift-inst sllx #b10 #b100101 :extended t) ; v9
- (define-f3-shift-inst srlx #b10 #b100110 :extended t) ; v9
- (define-f3-shift-inst srax #b10 #b100111 :extended t) ; v9
+ (define-f3-shift-inst sllx #b10 #b100101 :extended t) ; v9
+ (define-f3-shift-inst srlx #b10 #b100110 :extended t) ; v9
+ (define-f3-shift-inst srax #b10 #b100111 :extended t) ; v9
(define-f3-inst save #b10 #b111100 :reads :psr :writes :psr)
(define-f3-inst restore #b10 #b111101 :reads :psr :writes :psr)
-
+
;; smul, smulcc, umul, umulcc, sdiv, sdivcc, udiv, and udivcc are
;; deprecated on the Sparc V9. Use mulx, sdivx, and udivx instead.
- (define-f3-inst smul #b10 #b001011 :writes :y) ; v8
- (define-f3-inst smulcc #b10 #b011011 :writes (:psr :y)) ; v8
- (define-f3-inst umul #b10 #b001010 :writes :y) ; v8
- (define-f3-inst umulcc #b10 #b011010 :writes (:psr :y)) ; v8
- (define-f3-inst sdiv #b10 #b001111 :reads :y) ; v8
- (define-f3-inst sdivcc #b10 #b011111 :reads :y :writes :psr) ; v8
- (define-f3-inst udiv #b10 #b001110 :reads :y) ; v8
- (define-f3-inst udivcc #b10 #b011110 :reads :y :writes :psr) ; v8
-
- (define-f3-inst mulx #b10 #b001001) ; v9 for both signed and unsigned
- (define-f3-inst sdivx #b10 #b101101) ; v9
- (define-f3-inst udivx #b10 #b001101) ; v9
-
- (define-f3-inst popc #b10 #b101110) ; v9: count one bits
+ (define-f3-inst smul #b10 #b001011 :writes :y) ; v8
+ (define-f3-inst smulcc #b10 #b011011 :writes (:psr :y)) ; v8
+ (define-f3-inst umul #b10 #b001010 :writes :y) ; v8
+ (define-f3-inst umulcc #b10 #b011010 :writes (:psr :y)) ; v8
+ (define-f3-inst sdiv #b10 #b001111 :reads :y) ; v8
+ (define-f3-inst sdivcc #b10 #b011111 :reads :y :writes :psr) ; v8
+ (define-f3-inst udiv #b10 #b001110 :reads :y) ; v8
+ (define-f3-inst udivcc #b10 #b011110 :reads :y :writes :psr) ; v8
+
+ (define-f3-inst mulx #b10 #b001001) ; v9 for both signed and unsigned
+ (define-f3-inst sdivx #b10 #b101101) ; v9
+ (define-f3-inst udivx #b10 #b001101) ; v9
+
+ (define-f3-inst popc #b10 #b101110) ; v9: count one bits
) ; MACROLET
:pinned
(:delay 0)
(:emitter (emit-format-3-immed segment #b11 0 #b100001
- (reg-tn-encoding src1) 1 src2)))
+ (reg-tn-encoding src1) 1 src2)))
#!+sparc-64
(define-instruction ldxfsr (segment src1 src2)
(:declare (type tn src1) (type (signed-byte 13) src2))
(:printer format-3-immed ((op #b11) (op3 #b100001) (rd 1))
- '(:name :tab "[" rs1 (:unless (:constant 0) "+" immed) "], %FSR")
- :print-name 'ldx)
+ '(:name :tab "[" rs1 (:unless (:constant 0) "+" immed) "], %FSR")
+ :print-name 'ldx)
:pinned
(:delay 0)
(:emitter (emit-format-3-immed segment #b11 1 #b100001
- (reg-tn-encoding src1) 1 src2)))
-
+ (reg-tn-encoding src1) 1 src2)))
+
;; stfsr is deprecated on the Sparc V9. Use stxfsr instead.
(define-instruction stfsr (segment src1 src2)
(:declare (type tn src1) (type (signed-byte 13) src2))
(:printer format-3-immed ((op #b11) (op3 #b100101) (rd 0)))
:pinned
(:delay 0)
- (:emitter (emit-format-3-immed segment #b11 0 #b100101
- (reg-tn-encoding src1) 1 src2)))
+ (:emitter (emit-format-3-immed segment #b11 0 #b100101
+ (reg-tn-encoding src1) 1 src2)))
#!+sparc-64
(define-instruction stxfsr (segment src1 src2)
(:declare (type tn src1) (type (signed-byte 13) src2))
(:printer format-3-immed ((op #b11) (op3 #b100101) (rd 1))
- '(:name :tab "%FSR, [" rs1 "+" (:unless (:constant 0) "+" immed) "]")
- :print-name 'stx)
+ '(:name :tab "%FSR, [" rs1 "+" (:unless (:constant 0) "+" immed) "]")
+ :print-name 'stx)
:pinned
(:delay 0)
- (:emitter (emit-format-3-immed segment #b11 1 #b100101
- (reg-tn-encoding src1) 1 src2)))
+ (:emitter (emit-format-3-immed segment #b11 1 #b100101
+ (reg-tn-encoding src1) 1 src2)))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun sethi-arg-printer (value stream dstate)
;; sethi instruction. This is used later to print some possible
;; notes about the value loaded by sethi.
(let* ((word (sb!disassem::sap-ref-int (sb!disassem::dstate-segment-sap dstate)
- (sb!disassem::dstate-cur-offs dstate)
- n-word-bytes
- (sb!disassem::dstate-byte-order dstate)))
- (imm22 (ldb (byte 22 0) word))
- (rd (ldb (byte 5 25) word)))
+ (sb!disassem::dstate-cur-offs dstate)
+ n-word-bytes
+ (sb!disassem::dstate-byte-order dstate)))
+ (imm22 (ldb (byte 22 0) word))
+ (rd (ldb (byte 5 25) word)))
(push (cons rd imm22) *note-sethi-inst*)))
) ; EVAL-WHEN
(define-instruction sethi (segment dst src1)
(:declare (type tn dst)
- (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1))
+ (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1))
(:printer format-2-immed
((op2 #b100) (immed nil :printer #'sethi-arg-printer)))
(:dependencies (writes dst))
(etypecase src1
(integer
(emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100
- src1))
+ src1))
(fixup
(note-fixup segment :sethi src1)
(emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0)))))
-
+
;; rdy is deprecated on the Sparc V9. It's not needed with 64-bit
;; registers.
(define-instruction rdy (segment dst)
(:dependencies (reads :y) (writes dst))
(:delay 0)
(:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b101000
- 0 0 0 0)))
+ 0 0 0 0)))
(defconstant-eqx wry-printer
'('WR :tab rs1 (:unless (:constant 0) ", " (:choose immed rs2)) ", " '%Y)
(:delay 3)
(:emitter
(etypecase src2
- (null
+ (null
(emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0))
(tn
(emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0
- (reg-tn-encoding src2)))
+ (reg-tn-encoding src2)))
(integer
(emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1
- src2)))))
+ src2)))))
(defun snarf-error-junk (sap offset &optional length-only)
(let* ((length (sb!sys:sap-ref-8 sap offset))
(define-instruction unimp (segment data)
(:declare (type (unsigned-byte 22) data))
(:printer format-2-unimp () :default :control #'unimp-control
- :print-name #!-sparc-v9 'unimp #!+sparc-v9 'illtrap)
+ :print-name #!-sparc-v9 'unimp #!+sparc-v9 'illtrap)
(:delay 0)
(:emitter (emit-format-2-unimp segment 0 0 0 data)))
(defun emit-relative-branch (segment a op2 cond-or-target target &optional fp)
(emit-back-patch segment 4
(lambda (segment posn)
- (unless target
- (setf target cond-or-target)
- (setf cond-or-target :t))
- (emit-format-2-branch
- segment #b00 a
- (if fp
- (fp-branch-condition cond-or-target)
- (branch-condition cond-or-target))
- op2
- (let ((offset (ash (- (label-position target) posn) -2)))
- (when (and (= a 1) (> 0 offset))
- (error "Offset of BA must be positive"))
- offset)))))
+ (unless target
+ (setf target cond-or-target)
+ (setf cond-or-target :t))
+ (emit-format-2-branch
+ segment #b00 a
+ (if fp
+ (fp-branch-condition cond-or-target)
+ (branch-condition cond-or-target))
+ op2
+ (let ((offset (ash (- (label-position target) posn) -2)))
+ (when (and (= a 1) (> 0 offset))
+ (error "Offset of BA must be positive"))
+ offset)))))
(defun emit-relative-branch-integer (segment a op2 cond-or-target target &optional (cc :icc) (pred :pt))
(declare (type integer-condition-register cc))
(aver (member :sparc-v9 *backend-subfeatures*))
(emit-back-patch segment 4
(lambda (segment posn)
- (unless target
- (setf target cond-or-target)
- (setf cond-or-target :t))
- (emit-format-2-branch-pred
- segment #b00 a
- (branch-condition cond-or-target)
- op2
- (integer-condition cc)
- (branch-prediction pred)
- (let ((offset (ash (- (label-position target) posn) -2)))
- (when (and (= a 1) (> 0 offset))
- (error "Offset of BA must be positive"))
- offset)))))
+ (unless target
+ (setf target cond-or-target)
+ (setf cond-or-target :t))
+ (emit-format-2-branch-pred
+ segment #b00 a
+ (branch-condition cond-or-target)
+ op2
+ (integer-condition cc)
+ (branch-prediction pred)
+ (let ((offset (ash (- (label-position target) posn) -2)))
+ (when (and (= a 1) (> 0 offset))
+ (error "Offset of BA must be positive"))
+ offset)))))
(defun emit-relative-branch-fp (segment a op2 cond-or-target target &optional (cc :fcc0) (pred :pt))
(aver (member :sparc-v9 *backend-subfeatures*))
(emit-back-patch segment 4
(lambda (segment posn)
- (unless target
- (setf target cond-or-target)
- (setf cond-or-target :t))
- (emit-format-2-branch-pred
- segment #b00 a
- (fp-branch-condition cond-or-target)
- op2
- (fp-condition cc)
- (branch-prediction pred)
- (let ((offset (ash (- (label-position target) posn) -2)))
- (when (and (= a 1) (> 0 offset))
- (error "Offset of BA must be positive"))
- offset)))))
+ (unless target
+ (setf target cond-or-target)
+ (setf cond-or-target :t))
+ (emit-format-2-branch-pred
+ segment #b00 a
+ (fp-branch-condition cond-or-target)
+ op2
+ (fp-condition cc)
+ (branch-prediction pred)
+ (let ((offset (ash (- (label-position target) posn) -2)))
+ (when (and (= a 1) (> 0 offset))
+ (error "Offset of BA must be positive"))
+ offset)))))
;; So that I don't have to go change the syntax of every single use of
;; branches, I'm keeping the Lisp instruction names the same. They
(cond
((member :sparc-v9 *backend-subfeatures*)
(destructuring-bind (&optional target pred cc) args
- (declare (type (or label null) target))
- (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
+ (declare (type (or label null) target))
+ (emit-relative-branch-integer segment 0 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
(t
(destructuring-bind (&optional target) args
- (declare (type (or label null) target))
- (emit-relative-branch segment 0 #b010 cond-or-target target))))))
+ (declare (type (or label null) target))
+ (emit-relative-branch segment 0 #b010 cond-or-target target))))))
(define-instruction bp (segment cond-or-target &optional target pred cc)
(:declare (type (or label branch-condition) cond-or-target)
- (type (or label null) target))
+ (type (or label null) target))
(:printer format-2-branch-pred ((op #b00) (op2 #b001))
- branch-pred-printer
- :print-name 'bp)
+ branch-pred-printer
+ :print-name 'bp)
(:attributes branch)
(:dependencies (reads :psr))
(:delay 1)
(cond
((member :sparc-v9 *backend-subfeatures*)
(destructuring-bind (&optional target pred cc) args
- (declare (type (or label null) target))
- (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
+ (declare (type (or label null) target))
+ (emit-relative-branch-integer segment 1 #b001 cond-or-target target (or cc :icc) (or pred :pt))))
(t
(destructuring-bind (&optional target) args
- (declare (type (or label null) target))
- (emit-relative-branch segment 1 #b010 cond-or-target target))))))
+ (declare (type (or label null) target))
+ (emit-relative-branch segment 1 #b010 cond-or-target target))))))
(define-instruction bpa (segment cond-or-target &optional target pred cc)
(:declare (type (or label branch-condition) cond-or-target)
- (type (or label null) target))
+ (type (or label null) target))
(:printer format-2-branch ((op #b00) (op2 #b001) (a 1))
nil
:print-name 'bp)
(define-instruction t (segment condition target &optional cc)
(:declare (type branch-condition condition)
- ;; KLUDGE: see comments in vm.lisp regarding
- ;; pseudo-atomic-trap.
- #!-linux
- (type (integer 16 31) target))
+ ;; KLUDGE: see comments in vm.lisp regarding
+ ;; pseudo-atomic-trap.
+ #!-linux
+ (type (integer 16 31) target))
(:printer format-3-immed ((op #b10)
(rd nil :type 'branch-condition)
(op3 #b111010)
(:attributes branch)
(:dependencies (reads :psr))
(:delay 0)
- (:emitter
+ (:emitter
(cond
((member :sparc-v9 *backend-subfeatures*)
(unless cc
- (setf cc :icc))
+ (setf cc :icc))
(emit-format-4-trap segment
- #b10
- (branch-condition condition)
- #b111010 0 1
- (integer-condition cc)
- target))
+ #b10
+ (branch-condition condition)
+ #b111010 0 1
+ (integer-condition cc)
+ target))
(t
(aver (null cc))
(emit-format-3-immed segment #b10 (branch-condition condition)
- #b111010 0 1 target)))))
+ #b111010 0 1 target)))))
;;; KLUDGE: we leave this commented out, as these two (T and TCC)
;;; operations are actually indistinguishable from their bitfields,
#+nil
(define-instruction tcc (segment condition target &optional (cc #!-sparc-64 :icc #!+sparc-64 :xcc))
(:declare (type branch-condition condition)
- ;; KLUDGE: see above.
- #!-linux
- (type (integer 16 31) target)
- (type integer-condition-register cc))
+ ;; KLUDGE: see above.
+ #!-linux
+ (type (integer 16 31) target)
+ (type integer-condition-register cc))
(:printer format-4-trap ((op #b10)
(rd nil :type 'branch-condition)
(op3 #b111010)
(:dependencies (reads :psr))
(:delay 0)
(:emitter (emit-format-4-trap segment
- #b10
- (branch-condition condition)
- #b111010 0 1
- (integer-condition cc)
- target)))
+ #b10
+ (branch-condition condition)
+ #b111010 0 1
+ (integer-condition cc)
+ target)))
;; Same as for the branch instructions. On the Sparc V9, we will use
;; the FP branch with prediction instructions instead.
(cond
((member :sparc-v9 *backend-subfeatures*)
(destructuring-bind (&optional fcc pred) args
- (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))
- (t
+ (emit-relative-branch-fp segment 0 #b101 condition target (or fcc :fcc0) (or pred :pt))))
+ (t
(aver (null args))
(emit-relative-branch segment 0 #b110 condition target t)))))
(define-instruction fbp (segment condition target &optional fcc pred)
(:declare (type fp-branch-condition condition) (type label target))
(:printer format-2-fp-branch-pred ((op #b00) (op2 #b101))
- fp-branch-pred-printer
- :print-name 'fbp)
+ fp-branch-pred-printer
+ :print-name 'fbp)
(:attributes branch)
(:dependencies (reads :fsr))
(:delay 1)
(define-instruction jal (segment dst src1 &optional src2)
(:declare (type tn dst)
- (type (or tn integer) src1)
- (type (or null fixup tn (signed-byte 13)) src2))
+ (type (or tn integer) src1)
+ (type (or null fixup tn (signed-byte 13)) src2))
(:printer format-3-reg ((op #b10) (op3 #b111000)) jal-printer)
(:printer format-3-immed ((op #b10) (op3 #b111000)) jal-printer)
(:attributes branch)
(etypecase src2
(tn
(emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000
- (if (integerp src1)
- src1
- (reg-tn-encoding src1))
- 0 0 (reg-tn-encoding src2)))
+ (if (integerp src1)
+ src1
+ (reg-tn-encoding src1))
+ 0 0 (reg-tn-encoding src2)))
(integer
(emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000
- (reg-tn-encoding src1) 1 src2))
+ (reg-tn-encoding src1) 1 src2))
(fixup
(note-fixup segment :add src2)
(emit-format-3-immed segment #b10 (reg-tn-encoding dst)
- #b111000 (reg-tn-encoding src1) 1 0)))))
+ #b111000 (reg-tn-encoding src1) 1 0)))))
(define-instruction j (segment src1 &optional src2)
(:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2))
(emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0))
(tn
(emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0
- (reg-tn-encoding src2)))
+ (reg-tn-encoding src2)))
(integer
(emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
- src2))
+ src2))
(fixup
(note-fixup segment :add src2)
(emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
- 0)))))
+ 0)))))
\f
(:declare (type tn dst src))
(:printer format-unary-fpop
((op #b10) (op3 #b110100) (opf ,opf)
- (rs1 0)
- (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
- (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))))
+ (rs1 0)
+ (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+ (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))))
(:dependencies
,@(when reads
- `((reads ,reads)))
+ `((reads ,reads)))
(reads dst)
(reads src)
(writes dst))
(:delay 0)
(:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
- #b110100 0 ,opf (fp-reg-tn-encoding src)))))
+ #b110100 0 ,opf (fp-reg-tn-encoding src)))))
- (define-binary-fp-inst (name opf &key (op3 #b110100)
- reads writes delay extended)
+ (define-binary-fp-inst (name opf &key (op3 #b110100)
+ reads writes delay extended)
`(define-instruction ,name (segment dst src1 src2)
(:declare (type tn dst src1 src2))
(:printer format-binary-fpop
))
(:dependencies
,@(when reads
- `((reads ,reads)))
+ `((reads ,reads)))
(reads src1)
(reads src2)
,@(when writes
- `((writes ,writes)))
+ `((writes ,writes)))
(writes dst))
,@(if delay
- `((:delay ,delay))
- '((:delay 0)))
+ `((:delay ,delay))
+ '((:delay 0)))
(:emitter (emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst)
- ,op3 (fp-reg-tn-encoding src1) ,opf
- (fp-reg-tn-encoding src2)))))
-
- (define-cmp-fp-inst (name opf &key extended)
- (let ((opf0 #b0)
- (opf1 #b010)
- (opf2 #b1))
- `(define-instruction ,name (segment src1 src2 &optional (fcc :fcc0))
- (:declare (type tn src1 src2)
- (type (member :fcc0 :fcc1 :fcc2 :fcc3) fcc))
+ ,op3 (fp-reg-tn-encoding src1) ,opf
+ (fp-reg-tn-encoding src2)))))
+
+ (define-cmp-fp-inst (name opf &key extended)
+ (let ((opf0 #b0)
+ (opf1 #b010)
+ (opf2 #b1))
+ `(define-instruction ,name (segment src1 src2 &optional (fcc :fcc0))
+ (:declare (type tn src1 src2)
+ (type (member :fcc0 :fcc1 :fcc2 :fcc3) fcc))
(:printer format-fpop2
- ((op #b10)
- (op3 #b110101)
- (opf0 ,opf0)
- (opf1 ,opf1)
- (opf2 ,opf2)
- (opf3 ,opf)
- (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
- (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
- #!-sparc-v9
- (rd 0)
- #!+sparc-v9
- (rd nil :type 'fp-condition-register))
- )
+ ((op #b10)
+ (op3 #b110101)
+ (opf0 ,opf0)
+ (opf1 ,opf1)
+ (opf2 ,opf2)
+ (opf3 ,opf)
+ (rs1 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+ (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+ #!-sparc-v9
+ (rd 0)
+ #!+sparc-v9
+ (rd nil :type 'fp-condition-register))
+ )
(:dependencies
(reads src1)
(reads src2)
;; (:delay #-sparc-v9 1 #+sparc-v9 0)
(:delay 1)
(:emitter
- (emit-format-3-fpop2 segment #b10
- (or (position fcc '(:fcc0 :fcc1 :fcc2 :fcc3))
- 0)
- #b110101
- (fp-reg-tn-encoding src1)
- ,opf0 ,opf1 ,opf2 ,opf
- (fp-reg-tn-encoding src2)))))))
+ (emit-format-3-fpop2 segment #b10
+ (or (position fcc '(:fcc0 :fcc1 :fcc2 :fcc3))
+ 0)
+ #b110101
+ (fp-reg-tn-encoding src1)
+ ,opf0 ,opf1 ,opf2 ,opf
+ (fp-reg-tn-encoding src2)))))))
(define-unary-fp-inst fitos #b011000100 :reads :fsr)
(define-unary-fp-inst fitod #b011001000 :reads :fsr :extended t)
- (define-unary-fp-inst fitoq #b011001100 :reads :fsr :extended t) ; v8
-
+ (define-unary-fp-inst fitoq #b011001100 :reads :fsr :extended t) ; v8
+
(define-unary-fp-inst fxtos #b010000100 :reads :fsr) ; v9
(define-unary-fp-inst fxtod #b010001000 :reads :fsr :extended t) ; v9
- (define-unary-fp-inst fxtoq #b010001100 :reads :fsr :extended t) ; v9
+ (define-unary-fp-inst fxtoq #b010001100 :reads :fsr :extended t) ; v9
;; I (Raymond Toy) don't think these f{sd}toir instructions exist on
;; machines (sun3 68K machines?).
(define-unary-fp-inst fstoir #b011000001 :reads :fsr)
(define-unary-fp-inst fdtoir #b011000010 :reads :fsr)
-
+
(define-unary-fp-inst fstoi #b011010001)
(define-unary-fp-inst fdtoi #b011010010 :extended t)
- (define-unary-fp-inst fqtoi #b011010011 :extended t) ; v8
+ (define-unary-fp-inst fqtoi #b011010011 :extended t) ; v8
(define-unary-fp-inst fstox #b010000001) ; v9
(define-unary-fp-inst fdtox #b010000010 :extended t) ; v9
- (define-unary-fp-inst fqtox #b010000011 :extended t) ; v9
+ (define-unary-fp-inst fqtox #b010000011 :extended t) ; v9
(define-unary-fp-inst fstod #b011001001 :reads :fsr)
- (define-unary-fp-inst fstoq #b011001101 :reads :fsr) ; v8
+ (define-unary-fp-inst fstoq #b011001101 :reads :fsr) ; v8
(define-unary-fp-inst fdtos #b011000110 :reads :fsr)
- (define-unary-fp-inst fdtoq #b011001110 :reads :fsr) ; v8
- (define-unary-fp-inst fqtos #b011000111 :reads :fsr) ; v8
- (define-unary-fp-inst fqtod #b011001011 :reads :fsr) ; v8
-
+ (define-unary-fp-inst fdtoq #b011001110 :reads :fsr) ; v8
+ (define-unary-fp-inst fqtos #b011000111 :reads :fsr) ; v8
+ (define-unary-fp-inst fqtod #b011001011 :reads :fsr) ; v8
+
(define-unary-fp-inst fmovs #b000000001)
- (define-unary-fp-inst fmovd #b000000010 :extended t) ; v9
- (define-unary-fp-inst fmovq #b000000011 :extended t) ; v9
-
+ (define-unary-fp-inst fmovd #b000000010 :extended t) ; v9
+ (define-unary-fp-inst fmovq #b000000011 :extended t) ; v9
+
(define-unary-fp-inst fnegs #b000000101)
- (define-unary-fp-inst fnegd #b000000110 :extended t) ; v9
- (define-unary-fp-inst fnegq #b000000111 :extended t) ; v9
+ (define-unary-fp-inst fnegd #b000000110 :extended t) ; v9
+ (define-unary-fp-inst fnegq #b000000111 :extended t) ; v9
(define-unary-fp-inst fabss #b000001001)
- (define-unary-fp-inst fabsd #b000001010 :extended t) ; v9
- (define-unary-fp-inst fabsq #b000001011 :extended t) ; v9
-
- (define-unary-fp-inst fsqrts #b000101001 :reads :fsr) ; V7
- (define-unary-fp-inst fsqrtd #b000101010 :reads :fsr :extended t) ; V7
- (define-unary-fp-inst fsqrtq #b000101011 :reads :fsr :extended t) ; v8
-
+ (define-unary-fp-inst fabsd #b000001010 :extended t) ; v9
+ (define-unary-fp-inst fabsq #b000001011 :extended t) ; v9
+
+ (define-unary-fp-inst fsqrts #b000101001 :reads :fsr) ; V7
+ (define-unary-fp-inst fsqrtd #b000101010 :reads :fsr :extended t) ; V7
+ (define-unary-fp-inst fsqrtq #b000101011 :reads :fsr :extended t) ; v8
+
(define-binary-fp-inst fadds #b001000001)
(define-binary-fp-inst faddd #b001000010 :extended t)
- (define-binary-fp-inst faddq #b001000011 :extended t) ; v8
+ (define-binary-fp-inst faddq #b001000011 :extended t) ; v8
(define-binary-fp-inst fsubs #b001000101)
(define-binary-fp-inst fsubd #b001000110 :extended t)
- (define-binary-fp-inst fsubq #b001000111 :extended t) ; v8
-
+ (define-binary-fp-inst fsubq #b001000111 :extended t) ; v8
+
(define-binary-fp-inst fmuls #b001001001)
(define-binary-fp-inst fmuld #b001001010 :extended t)
- (define-binary-fp-inst fmulq #b001001011 :extended t) ; v8
+ (define-binary-fp-inst fmulq #b001001011 :extended t) ; v8
(define-binary-fp-inst fdivs #b001001101)
(define-binary-fp-inst fdivd #b001001110 :extended t)
- (define-binary-fp-inst fdivq #b001001111 :extended t) ; v8
+ (define-binary-fp-inst fdivq #b001001111 :extended t) ; v8
;;; Float comparison instructions.
;;;
(define-cmp-fp-inst fcmpq #b0011 :extended t) ;v8
(define-cmp-fp-inst fcmpes #b0101)
(define-cmp-fp-inst fcmped #b0110 :extended t)
- (define-cmp-fp-inst fcmpeq #b0111 :extended t) ; v8
+ (define-cmp-fp-inst fcmpeq #b0111 :extended t) ; v8
) ; MACROLET
\f
(inst add reg zero-tn value))
((or (signed-byte 32) (unsigned-byte 32))
(let ((hi (ldb (byte 22 10) value))
- (lo (ldb (byte 10 0) value)))
+ (lo (ldb (byte 10 0) value)))
(inst sethi reg hi)
(unless (zerop lo)
- (inst add reg lo))))
+ (inst add reg lo))))
(fixup
(inst sethi reg value)
(inst add reg value))))
;;; Jal to a full 32-bit address. Tmpreg is trashed.
(define-instruction jali (segment link tmpreg value)
(:declare (type tn link tmpreg)
- (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
- fixup) value))
+ (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
+ fixup) value))
(:attributes variable-length)
(:vop-var vop)
(:attributes branch)
(assemble (segment vop)
(etypecase value
((signed-byte 13)
- (inst jal link zero-tn value))
+ (inst jal link zero-tn value))
((or (signed-byte 32) (unsigned-byte 32))
- (let ((hi (ldb (byte 22 10) value))
- (lo (ldb (byte 10 0) value)))
- (inst sethi tmpreg hi)
- (inst jal link tmpreg lo)))
+ (let ((hi (ldb (byte 22 10) value))
+ (lo (ldb (byte 10 0) value)))
+ (inst sethi tmpreg hi)
+ (inst jal link tmpreg lo)))
(fixup
- (inst sethi tmpreg value)
- (inst jal link tmpreg value))))))
+ (inst sethi tmpreg value)
+ (inst jal link tmpreg value))))))
;;; Jump to a full 32-bit address. Tmpreg is trashed.
(define-instruction ji (segment tmpreg value)
(:declare (type tn tmpreg)
- (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
- fixup) value))
+ (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
+ fixup) value))
(:attributes variable-length)
(:vop-var vop)
(:attributes branch)
(:delay 1)
(:emitter
(assemble (segment vop)
- (inst jali zero-tn tmpreg value))))
+ (inst jali zero-tn tmpreg value))))
(define-instruction nop (segment)
(:printer format-2-immed ((rd 0) (op2 #b100) (immed 0)) '(:name))
(emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0))
(tn
(emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0
- (reg-tn-encoding src2)))
+ (reg-tn-encoding src2)))
(integer
(emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1
- src2)))))
+ src2)))))
(define-instruction not (segment dst &optional src1)
(:declare (type tn dst) (type (or tn null) src1))
(unless src1
(setf src1 dst))
(emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111
- (reg-tn-encoding src1) 0 0 0)))
+ (reg-tn-encoding src1) 0 0 0)))
(define-instruction neg (segment dst &optional src1)
(:declare (type tn dst) (type (or tn null) src1))
(unless src1
(setf src1 dst))
(emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100
- 0 0 0 (reg-tn-encoding src1))))
+ 0 0 0 (reg-tn-encoding src1))))
(define-instruction move (segment dst src1)
(:declare (type tn dst src1))
(:printer format-3-reg ((op #b10) (op3 #b000010) (rs1 0))
'(:name :tab rs2 ", " rd)
- :print-name 'mov)
+ :print-name 'mov)
(:attributes flushable)
(:dependencies (reads src1) (writes dst))
(:delay 0)
(:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010
- 0 0 0 (reg-tn-encoding src1))))
+ 0 0 0 (reg-tn-encoding src1))))
\f
(define-bitfield-emitter emit-header-object 32
(byte 24 8) (byte 8 0))
-
+
(defun emit-header-data (segment type)
(emit-back-patch
segment 4
(lambda (segment posn)
(emit-word segment
- (logior type
- (ash (+ posn (component-header-length))
- (- n-widetag-bits word-shift)))))))
+ (logior type
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift)))))))
(define-instruction simple-fun-header-word (segment)
:pinned
segment 12 3
(lambda (segment posn delta-if-after)
(let ((delta (funcall calc label posn delta-if-after)))
- (when (<= (- (ash 1 12)) delta (1- (ash 1 12)))
- (emit-back-patch segment 4
- (lambda (segment posn)
- (assemble (segment vop)
- (inst add dst src
- (funcall calc label posn 0)))))
- t)))
+ (when (<= (- (ash 1 12)) delta (1- (ash 1 12)))
+ (emit-back-patch segment 4
+ (lambda (segment posn)
+ (assemble (segment vop)
+ (inst add dst src
+ (funcall calc label posn 0)))))
+ t)))
(lambda (segment posn)
(let ((delta (funcall calc label posn 0)))
- (assemble (segment vop)
- (inst sethi temp (ldb (byte 22 10) delta))
- (inst or temp (ldb (byte 10 0) delta))
- (inst add dst src temp))))))
+ (assemble (segment vop)
+ (inst sethi temp (ldb (byte 22 10) delta))
+ (inst or temp (ldb (byte 10 0) delta))
+ (inst add dst src temp))))))
;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-fn (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- (lambda (label posn delta-if-after)
- (- other-pointer-lowtag
- fun-pointer-lowtag
- (label-position label posn delta-if-after)
- (component-header-length))))))
+ (lambda (label posn delta-if-after)
+ (- other-pointer-lowtag
+ fun-pointer-lowtag
+ (label-position label posn delta-if-after)
+ (component-header-length))))))
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
(define-instruction compute-code-from-lra (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- (lambda (label posn delta-if-after)
- (- (+ (label-position label posn delta-if-after)
- (component-header-length)))))))
+ (lambda (label posn delta-if-after)
+ (- (+ (label-position label posn delta-if-after)
+ (component-header-length)))))))
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
(define-instruction compute-lra-from-code (segment dst src label temp)
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
- (lambda (label posn delta-if-after)
- (+ (label-position label posn delta-if-after)
- (component-header-length))))))
+ (lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length))))))
\f
;;; Sparc V9 additions
;; Conditional move integer on condition code
(define-instruction cmove (segment condition dst src &optional (ccreg :icc))
(:declare (type (or branch-condition fp-branch-condition) condition)
- (type cond-move-condition-register ccreg)
- (type tn dst)
- (type (or (signed-byte 13) tn) src))
+ (type cond-move-condition-register ccreg)
+ (type tn dst)
+ (type (or (signed-byte 13) tn) src))
(:printer format-4-cond-move
- ((op #b10)
- (op3 #b101100)
- (cc2 #b1)
- (i 0)
- (cc nil :type 'integer-condition-register))
- cond-move-printer
- :print-name 'mov)
+ ((op #b10)
+ (op3 #b101100)
+ (cc2 #b1)
+ (i 0)
+ (cc nil :type 'integer-condition-register))
+ cond-move-printer
+ :print-name 'mov)
(:printer format-4-cond-move-immed
- ((op #b10)
- (op3 #b101100)
- (cc2 #b1)
- (i 1)
- (cc nil :type 'integer-condition-register))
- cond-move-printer
- :print-name 'mov)
+ ((op #b10)
+ (op3 #b101100)
+ (cc2 #b1)
+ (i 1)
+ (cc nil :type 'integer-condition-register))
+ cond-move-printer
+ :print-name 'mov)
(:printer format-4-cond-move
- ((op #b10)
- (op3 #b101100)
- (cc2 #b0)
- (cond nil :type 'branch-fp-condition)
- (i 0)
- (cc nil :type 'fp-condition-register))
- cond-move-printer
- :print-name 'mov)
+ ((op #b10)
+ (op3 #b101100)
+ (cc2 #b0)
+ (cond nil :type 'branch-fp-condition)
+ (i 0)
+ (cc nil :type 'fp-condition-register))
+ cond-move-printer
+ :print-name 'mov)
(:printer format-4-cond-move-immed
- ((op #b10)
- (op3 #b101100)
- (cc2 #b0)
- (cond nil :type 'branch-fp-condition)
- (i 1)
- (cc nil :type 'fp-condition-register))
- cond-move-printer
- :print-name 'mov)
+ ((op #b10)
+ (op3 #b101100)
+ (cc2 #b0)
+ (cond nil :type 'branch-fp-condition)
+ (i 1)
+ (cc nil :type 'fp-condition-register))
+ cond-move-printer
+ :print-name 'mov)
(:delay 0)
(:dependencies
(if (member ccreg '(:icc :xcc))
(writes dst))
(:emitter
(let ((op #b10)
- (op3 #b101100))
+ (op3 #b101100))
(multiple-value-bind (cc2 cc01)
- (cond-move-condition-parts ccreg)
+ (cond-move-condition-parts ccreg)
(etypecase src
- (tn
- (emit-format-4-cond-move segment
- op
- (reg-tn-encoding dst)
- op3
- cc2
- (if (member ccreg '(:icc :xcc))
- (branch-condition condition)
- (fp-branch-condition condition))
- 0
- cc01
- (reg-tn-encoding src)))
- (integer
- (emit-format-4-cond-move segment
- op
- (reg-tn-encoding dst)
- op3
- cc2
- (if (member ccreg '(:icc :xcc))
- (branch-condition condition)
- (fp-branch-condition condition))
- 1
- cc01
- src)))))))
+ (tn
+ (emit-format-4-cond-move segment
+ op
+ (reg-tn-encoding dst)
+ op3
+ cc2
+ (if (member ccreg '(:icc :xcc))
+ (branch-condition condition)
+ (fp-branch-condition condition))
+ 0
+ cc01
+ (reg-tn-encoding src)))
+ (integer
+ (emit-format-4-cond-move segment
+ op
+ (reg-tn-encoding dst)
+ op3
+ cc2
+ (if (member ccreg '(:icc :xcc))
+ (branch-condition condition)
+ (fp-branch-condition condition))
+ 1
+ cc01
+ src)))))))
;; Conditional move floating-point on condition codes
(macrolet ((define-cond-fp-move (name print-name op op3 opf_low &key extended)
`(define-instruction ,name (segment condition dst src &optional (ccreg :fcc0))
(:declare (type (or branch-condition fp-branch-condition) condition)
- (type cond-move-condition-register ccreg)
- (type tn dst src))
+ (type cond-move-condition-register ccreg)
+ (type tn dst src))
(:printer format-fpop2
- ((op ,op)
- (op3 ,op3)
- (opf0 0)
- (opf1 nil :type 'fp-condition-register-shifted)
- (opf2 0)
- (opf3 ,opf_low)
- (rs1 nil :type 'branch-fp-condition)
- (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
- (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
+ ((op ,op)
+ (op3 ,op3)
+ (opf0 0)
+ (opf1 nil :type 'fp-condition-register-shifted)
+ (opf2 0)
+ (opf3 ,opf_low)
+ (rs1 nil :type 'branch-fp-condition)
+ (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+ (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
cond-fp-move-printer
:print-name ',print-name)
(:printer format-fpop2
- ((op ,op)
- (op3 ,op3)
- (opf0 1)
- (opf1 nil :type 'integer-condition-register)
- (opf2 0)
- (rs1 nil :type 'branch-condition)
- (opf3 ,opf_low)
- (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
- (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
+ ((op ,op)
+ (op3 ,op3)
+ (opf0 1)
+ (opf1 nil :type 'integer-condition-register)
+ (opf2 0)
+ (rs1 nil :type 'branch-condition)
+ (opf3 ,opf_low)
+ (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+ (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg)))
cond-fp-move-printer
:print-name ',print-name)
(:delay 0)
(:dependencies
(if (member ccreg '(:icc :xcc))
- (reads :psr)
- (reads :fsr))
+ (reads :psr)
+ (reads :fsr))
(reads src)
(reads dst)
(writes dst))
(:emitter
(multiple-value-bind (opf_cc2 opf_cc01)
- (cond-move-condition-parts ccreg)
- (emit-format-3-fpop2 segment
- ,op
- (fp-reg-tn-encoding dst)
- ,op3
- (if (member ccreg '(:icc :xcc))
- (branch-condition condition)
- (fp-branch-condition condition))
- opf_cc2
- (ash opf_cc01 1)
- 0
- ,opf_low
- (fp-reg-tn-encoding src)))))))
+ (cond-move-condition-parts ccreg)
+ (emit-format-3-fpop2 segment
+ ,op
+ (fp-reg-tn-encoding dst)
+ ,op3
+ (if (member ccreg '(:icc :xcc))
+ (branch-condition condition)
+ (fp-branch-condition condition))
+ opf_cc2
+ (ash opf_cc01 1)
+ 0
+ ,opf_low
+ (fp-reg-tn-encoding src)))))))
(define-cond-fp-move cfmovs fmovs #b10 #b110101 #b0001)
(define-cond-fp-move cfmovd fmovd #b10 #b110101 #b0010 :extended t)
(define-cond-fp-move cfmovq fmovq #b10 #b110101 #b0011 :extended t))
;;
(define-instruction movr (segment dst src2 src1 reg-condition)
(:declare (type cond-move-integer-condition reg-condition)
- (type tn dst src1)
- (type (or (signed-byte 10) tn) src2))
+ (type tn dst src1)
+ (type (or (signed-byte 10) tn) src2))
(:printer format-4-cond-move-integer
- ((op #b10)
- (op3 #b101111)
- (i 0)))
+ ((op #b10)
+ (op3 #b101111)
+ (i 0)))
(:printer format-4-cond-move-integer-immed
- ((op #b10)
- (op3 #b101111)
- (i 1)))
+ ((op #b10)
+ (op3 #b101111)
+ (i 1)))
(:delay 0)
(:dependencies
(reads :psr)
(macrolet ((define-cond-fp-move-integer (name opf_low &key extended)
`(define-instruction ,name (segment dst src2 src1 reg-condition)
(:declare (type cond-move-integer-condition reg-condition)
- (type tn dst src1 src2))
+ (type tn dst src1 src2))
(:printer format-fpop2
- ((op #b10)
- (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))
- (op3 #b110101)
- (rs1 nil :type 'reg)
- (opf0 0)
- (opf1 nil :type 'register-condition)
- (opf2 0)
- (opf3 ,opf_low)
- (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
- )
+ ((op #b10)
+ (rd nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+ (op3 #b110101)
+ (rs1 nil :type 'reg)
+ (opf0 0)
+ (opf1 nil :type 'register-condition)
+ (opf2 0)
+ (opf3 ,opf_low)
+ (rs2 nil :type ',(if extended 'fp-ext-reg 'fp-reg))
+ )
cond-fp-move-integer-printer)
(:delay 0)
(:dependencies
(defmacro move (dst src)
"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 move ,n-dst ,n-src))))
(macrolet
((def (op inst shift)
`(defmacro ,op (object base &optional (offset 0) (lowtag 0))
- `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
+ `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
(def loadw ld word-shift)
(def storew st word-shift))
(macrolet
((frob (slot)
(let ((loader (intern (concatenate 'simple-string
- "LOAD-SYMBOL-"
- (string slot))))
- (storer (intern (concatenate 'simple-string
- "STORE-SYMBOL-"
- (string slot))))
- (offset (intern (concatenate 'simple-string
- "SYMBOL-"
- (string slot)
- "-SLOT")
- (find-package "SB!VM"))))
- `(progn
- (defmacro ,loader (reg symbol)
- `(inst ld ,reg null-tn
- (+ (static-symbol-offset ',symbol)
- (ash ,',offset word-shift)
- (- other-pointer-lowtag))))
- (defmacro ,storer (reg symbol)
- `(inst st ,reg null-tn
- (+ (static-symbol-offset ',symbol)
- (ash ,',offset word-shift)
- (- other-pointer-lowtag))))))))
+ "LOAD-SYMBOL-"
+ (string slot))))
+ (storer (intern (concatenate 'simple-string
+ "STORE-SYMBOL-"
+ (string slot))))
+ (offset (intern (concatenate 'simple-string
+ "SYMBOL-"
+ (string slot)
+ "-SLOT")
+ (find-package "SB!VM"))))
+ `(progn
+ (defmacro ,loader (reg symbol)
+ `(inst ld ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash ,',offset word-shift)
+ (- other-pointer-lowtag))))
+ (defmacro ,storer (reg symbol)
+ `(inst st ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash ,',offset word-shift)
+ (- other-pointer-lowtag))))))))
(frob value)
(frob function))
"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))
;; FIXME: although I don't understand entirely, I'm going to do
;; what whn does in x86/macros.lisp -- Christophe
(ecase *backend-byte-order*
`(inst ldub ,n-target ,n-source (+ ,n-offset 3))))))
;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions.
+;;; return instructions.
(defmacro lisp-jump (fun)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
(inst j ,fun
- (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
+ (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
(move code-tn ,fun)))
(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
"Return to RETURN-PC."
`(progn
(inst j ,return-pc
- (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
+ (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
,(if frob-code
- `(move code-tn ,return-pc)
- '(inst nop))))
+ `(move code-tn ,return-pc)
+ '(inst nop))))
(defmacro emit-return-pc (label)
"Emit a return-pc header word. LABEL is the label to use for this return-pc."
;;; Move a stack TN to a register and vice-versa.
(defmacro load-stack-tn (reg stack)
`(let ((reg ,reg)
- (stack ,stack))
+ (stack ,stack))
(let ((offset (tn-offset stack)))
(sc-case stack
- ((control-stack)
- (loadw reg cfp-tn offset))))))
+ ((control-stack)
+ (loadw reg cfp-tn offset))))))
(defmacro store-stack-tn (stack reg)
`(let ((stack ,stack)
- (reg ,reg))
+ (reg ,reg))
(let ((offset (tn-offset stack)))
(sc-case stack
- ((control-stack)
- (storew reg cfp-tn offset))))))
+ ((control-stack)
+ (storew reg cfp-tn offset))))))
(defmacro maybe-load-stack-tn (reg reg-or-stack)
"Move the TN Reg-Or-Stack into Reg if it isn't already there."
(once-only ((n-reg reg)
- (n-stack reg-or-stack))
+ (n-stack reg-or-stack))
`(sc-case ,n-reg
((any-reg descriptor-reg)
- (sc-case ,n-stack
- ((any-reg descriptor-reg)
- (move ,n-reg ,n-stack))
- ((control-stack)
- (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+ (sc-case ,n-stack
+ ((any-reg descriptor-reg)
+ (move ,n-reg ,n-stack))
+ ((control-stack)
+ (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
\f
;;;; Storage allocation:
(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
- &body body)
+ &body body)
"Do stuff to allocate an other-pointer object of fixed Size with a single
word header having the specified Type-Code. The result is placed in
Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
(unless body
(bug "empty &body in WITH-FIXED-ALLOCATION"))
(once-only ((result-tn result-tn) (temp-tn temp-tn)
- (type-code type-code) (size size))
+ (type-code type-code) (size size))
`(pseudo-atomic (:extra (pad-data-block ,size))
(inst or ,result-tn alloc-tn other-pointer-lowtag)
(inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
;; FIXME: why use a TEMP? Why not just ZERO-TN?
(inst andcc temp csp-tn lowtag-mask)
(if (member :sparc-v9 *backend-subfeatures*)
- (inst b :eq aligned :pt)
- (inst b :eq aligned))
+ (inst b :eq aligned :pt)
+ (inst b :eq aligned))
(storew zero-tn csp-tn 0) ; sneaky use of delay slot
(inst add csp-tn csp-tn n-word-bytes)
(emit-label aligned)))
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
`((let ((vop ,vop))
- (when vop
- (note-this-location vop :internal-error)))
- (inst unimp ,kind)
- (with-adjustable-vector (,vector)
- (write-var-integer (error-number-or-lose ',code) ,vector)
- ,@(mapcar #'(lambda (tn)
- `(let ((tn ,tn))
- (write-var-integer (make-sc-offset (sc-number
- (tn-sc tn))
- (tn-offset tn))
- ,vector)))
- values)
- (inst byte (length ,vector))
- (dotimes (i (length ,vector))
- (inst byte (aref ,vector i))))
- (align word-shift)))))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst unimp ,kind)
+ (with-adjustable-vector (,vector)
+ (write-var-integer (error-number-or-lose ',code) ,vector)
+ ,@(mapcar #'(lambda (tn)
+ `(let ((tn ,tn))
+ (write-var-integer (make-sc-offset (sc-number
+ (tn-sc tn))
+ (tn-offset tn))
+ ,vector)))
+ values)
+ (inst byte (length ,vector))
+ (dotimes (i (length ,vector))
+ (inst byte (aref ,vector i))))
+ (align word-shift)))))
(defmacro error-call (vop error-code &rest values)
"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 cerror-call (vop label error-code &rest values)
`(let ((,continue (gen-label)))
(emit-label ,continue)
(assemble (*elsewhere*)
- (let ((,error (gen-label)))
- (emit-label ,error)
- (cerror-call ,vop ,continue ,error-code ,@values)
- ,error)))))
+ (let ((,error (gen-label)))
+ (emit-label ,error)
+ (cerror-call ,vop ,continue ,error-code ,@values)
+ ,error)))))
\f
;;; a handy macro for making sequences look atomic
(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
`(let ((,n-extra ,extra))
;; Set the pseudo-atomic flag.
(without-scheduling ()
- (inst add alloc-tn 4))
+ (inst add alloc-tn 4))
,@forms
;; Reset the pseudo-atomic flag.
(without-scheduling ()
- #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
- ;; Remove the pseudo-atomic flag.
- (inst add alloc-tn (- ,n-extra 4))
- ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
- (inst andcc zero-tn alloc-tn 3)
- ;; The C code needs to process this correctly and fixup alloc-tn.
- (inst t :ne pseudo-atomic-trap)))))
+ #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
+ ;; Remove the pseudo-atomic flag.
+ (inst add alloc-tn (- ,n-extra 4))
+ ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
+ (inst andcc zero-tn alloc-tn 3)
+ ;; The C code needs to process this correctly and fixup alloc-tn.
+ (inst t :ne pseudo-atomic-trap)))))
(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
garbage collection. This is currently implemented by disabling GC"
- (declare (ignore objects)) ;should we eval these for side-effect?
+ (declare (ignore objects)) ;should we eval these for side-effect?
`(without-gcing
,@body))
(define-vop (slot-set)
(:args (object :scs (descriptor-reg))
- (value :scs (descriptor-reg any-reg)))
+ (value :scs (descriptor-reg any-reg)))
(:variant-vars base lowtag)
(:info offset)
(:generator 4
;;; Define some VOPs for indexed memory reference.
(macrolet ((define-indexer (name write-p op shift)
- `(define-vop (,name)
- (:args (object :scs (descriptor-reg))
- (index :scs (any-reg zero immediate))
- ,@(when write-p
- '((value :scs (any-reg descriptor-reg) :target result))))
- (:arg-types * tagged-num ,@(when write-p '(*)))
- (:temporary (:scs (non-descriptor-reg)) temp)
- (:results (,(if write-p 'result 'value)
- :scs (any-reg descriptor-reg)))
- (:result-types *)
- (:variant-vars offset lowtag)
- (:policy :fast-safe)
- (:generator 5
- (sc-case index
- ((immediate zero)
- (let ((offset (- (+ (if (sc-is index zero)
- 0
- (ash (tn-value index)
- (- word-shift ,shift)))
- (ash offset word-shift))
- lowtag)))
- (etypecase offset
- ((signed-byte 13)
- (inst ,op value object offset))
- ((or (unsigned-byte 32) (signed-byte 32))
- (inst li temp offset)
- (inst ,op value object temp)))))
- (t
- ,@(unless (zerop shift)
- `((inst srl temp index ,shift)))
- (inst add temp ,(if (zerop shift) 'index 'temp)
- (- (ash offset word-shift) lowtag))
- (inst ,op value object temp)))
- ,@(when write-p
- '((move result value)))))))
+ `(define-vop (,name)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg zero immediate))
+ ,@(when write-p
+ '((value :scs (any-reg descriptor-reg) :target result))))
+ (:arg-types * tagged-num ,@(when write-p '(*)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:results (,(if write-p 'result 'value)
+ :scs (any-reg descriptor-reg)))
+ (:result-types *)
+ (:variant-vars offset lowtag)
+ (:policy :fast-safe)
+ (:generator 5
+ (sc-case index
+ ((immediate zero)
+ (let ((offset (- (+ (if (sc-is index zero)
+ 0
+ (ash (tn-value index)
+ (- word-shift ,shift)))
+ (ash offset word-shift))
+ lowtag)))
+ (etypecase offset
+ ((signed-byte 13)
+ (inst ,op value object offset))
+ ((or (unsigned-byte 32) (signed-byte 32))
+ (inst li temp offset)
+ (inst ,op value object temp)))))
+ (t
+ ,@(unless (zerop shift)
+ `((inst srl temp index ,shift)))
+ (inst add temp ,(if (zerop shift) 'index 'temp)
+ (- (ash offset word-shift) lowtag))
+ (inst ,op value object temp)))
+ ,@(when write-p
+ '((move result value)))))))
(define-indexer word-index-ref nil ld 0)
(define-indexer word-index-set t st 0)
(define-indexer halfword-index-ref nil lduh 1)
(load-symbol y val))
(character
(inst li y (logior (ash (char-code val) n-widetag-bits)
- character-widetag))))))
+ character-widetag))))))
(define-move-fun (load-number 1) (vop x y)
((immediate zero)
(define-vop (move)
(:args (x :target y
- :scs (any-reg descriptor-reg zero null)
- :load-if (not (location= x y))))
+ :scs (any-reg descriptor-reg zero null)
+ :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))))
(:effects)
(:affected)
(:generator 0
;;; another frame for argument or known value passing.
(define-vop (move-arg)
(:args (x :target y
- :scs (any-reg descriptor-reg zero null))
- (fp :scs (any-reg)
- :load-if (not (sc-is y any-reg descriptor-reg))))
+ :scs (any-reg descriptor-reg zero null))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y any-reg descriptor-reg))))
(:results (y))
(:generator 0
(sc-case y
(inst andcc temp x fixnum-tag-mask)
(inst b :eq done)
(inst sra y x n-fixnum-tag-bits)
-
+
(loadw y x bignum-digits-offset other-pointer-lowtag)
-
+
(emit-label done))))
(define-move-vop move-to-word/integer :move
(:generator 20
(move x arg)
(let ((fixnum (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(inst sra temp x n-positive-fixnum-bits)
(inst cmp temp)
(inst b :eq fixnum)
(inst orncc temp zero-tn temp)
(inst b :eq done)
(inst sll y x n-fixnum-tag-bits)
-
+
(with-fixed-allocation
- (y temp bignum-widetag (1+ bignum-digits-offset))
- (storew x y bignum-digits-offset other-pointer-lowtag))
+ (y temp bignum-widetag (1+ bignum-digits-offset))
+ (storew x y bignum-digits-offset other-pointer-lowtag))
(inst b done)
(inst nop)
-
+
(emit-label fixnum)
(inst sll y x n-fixnum-tag-bits)
(emit-label done))))
(:generator 20
(move x arg)
(let ((done (gen-label))
- (one-word (gen-label)))
+ (one-word (gen-label)))
(inst sra temp x n-positive-fixnum-bits)
(inst cmp temp)
(inst b :eq done)
;; We always allocate 2 words even if we don't need it. (The
;; copying GC will take care of freeing the unused extra word.)
(with-fixed-allocation
- (y temp bignum-widetag (+ 2 bignum-digits-offset))
- (inst cmp x)
- (inst b :ge one-word)
- (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
- (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
- (emit-label one-word)
- ;; Set the header word, then the actual digit. The extra
- ;; digit, if any, is automatically set to zero, so we don't
- ;; have to.
- (storew temp y 0 other-pointer-lowtag)
- (storew x y bignum-digits-offset other-pointer-lowtag))
+ (y temp bignum-widetag (+ 2 bignum-digits-offset))
+ (inst cmp x)
+ (inst b :ge one-word)
+ (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
+ (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+ (emit-label one-word)
+ ;; Set the header word, then the actual digit. The extra
+ ;; digit, if any, is automatically set to zero, so we don't
+ ;; have to.
+ (storew temp y 0 other-pointer-lowtag)
+ (storew x y bignum-digits-offset other-pointer-lowtag))
(emit-label done))))
(define-move-vop move-from-unsigned :move
;;; Move untagged numbers.
(define-vop (word-move)
(:args (x :target y
- :scs (signed-reg unsigned-reg)
- :load-if (not (location= x y))))
+ :scs (signed-reg unsigned-reg)
+ :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))))
(:effects)
(:affected)
(:note "word integer move")
;;; Move untagged number arguments/return-values.
(define-vop (move-word-arg)
(:args (x :target y
- :scs (signed-reg unsigned-reg))
- (fp :scs (any-reg)
- :load-if (not (sc-is y sap-reg))))
+ :scs (signed-reg unsigned-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "word integer argument move")
(:generator 0
(define-vop (save-dynamic-state)
(:results (catch :scs (descriptor-reg))
- (nfp :scs (descriptor-reg))
- (nsp :scs (descriptor-reg)))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 13
- (load-symbol-value catch *current-catch-block*)
- (let ((cur-nfp (current-nfp-tn vop)))
- (when cur-nfp
- (move nfp cur-nfp)))
- (move nsp nsp-tn)))
+ (load-symbol-value catch *current-catch-block*)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (move nfp cur-nfp)))
+ (move nsp nsp-tn)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
- (nfp :scs (descriptor-reg))
- (nsp :scs (descriptor-reg)))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg)))
(:vop-var vop)
(:generator 10
- (store-symbol-value catch *current-catch-block*)
- (let ((cur-nfp (current-nfp-tn vop)))
- (when cur-nfp
- (move cur-nfp nfp)))
- (move nsp-tn nsp)))
+ (store-symbol-value catch *current-catch-block*)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (move cur-nfp nfp)))
+ (move nsp-tn nsp)))
(define-vop (current-stack-pointer)
(:results (res :scs (any-reg descriptor-reg)))
(:generator 1
- (move res csp-tn)))
+ (move res csp-tn)))
(define-vop (current-binding-pointer)
(:results (res :scs (any-reg descriptor-reg)))
(:generator 1
- (move res bsp-tn)))
+ (move res bsp-tn)))
\f
;;;; unwind block hackery:
;;; link the block into the Current-Catch list.
(define-vop (make-catch-block)
(:args (tn)
- (tag :scs (any-reg descriptor-reg)))
+ (tag :scs (any-reg descriptor-reg)))
(:info entry-label)
(:results (block :scs (any-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(define-vop (nlx-entry)
(:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
- ; would be inserted before the LRA.
- (start)
- (count))
+ ; would be inserted before the LRA.
+ (start)
+ (count))
(:results (values :more t))
(:temporary (:scs (descriptor-reg)) move-temp)
(:info label nvals)
(emit-return-pc label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
- ((= nvals 1)
- (let ((no-values (gen-label)))
- (inst cmp count)
- (inst b :eq no-values)
- (move (tn-ref-tn values) null-tn)
- (loadw (tn-ref-tn values) start)
- (emit-label no-values)))
- (t
- (collect ((defaults))
- (inst subcc count (fixnumize 1))
- (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 b :lt default-lab)
- (inst subcc count (fixnumize 1))
- (sc-case tn
- ((descriptor-reg any-reg)
- (loadw tn start i))
- (control-stack
- (loadw move-temp start i)
- (store-stack-tn tn move-temp)))))
-
- (let ((defaulting-done (gen-label)))
-
- (emit-label defaulting-done)
-
- (assemble (*elsewhere*)
- (dolist (def (defaults))
- (emit-label (car def))
- (let ((tn (cdr def)))
- (sc-case tn
- ((descriptor-reg any-reg)
- (move tn null-tn))
- (control-stack
- (store-stack-tn tn null-tn)))))
- (inst b defaulting-done)
- (inst nop))))))
+ ((= nvals 1)
+ (let ((no-values (gen-label)))
+ (inst cmp count)
+ (inst b :eq no-values)
+ (move (tn-ref-tn values) null-tn)
+ (loadw (tn-ref-tn values) start)
+ (emit-label no-values)))
+ (t
+ (collect ((defaults))
+ (inst subcc count (fixnumize 1))
+ (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 b :lt default-lab)
+ (inst subcc count (fixnumize 1))
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (loadw tn start i))
+ (control-stack
+ (loadw move-temp start i)
+ (store-stack-tn tn move-temp)))))
+
+ (let ((defaulting-done (gen-label)))
+
+ (emit-label defaulting-done)
+
+ (assemble (*elsewhere*)
+ (dolist (def (defaults))
+ (emit-label (car def))
+ (let ((tn (cdr def)))
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (move tn null-tn))
+ (control-stack
+ (store-stack-tn tn null-tn)))))
+ (inst b defaulting-done)
+ (inst nop))))))
(load-stack-tn csp-tn sp)))
(:temporary (:scs (any-reg)) dst)
(:temporary (:scs (descriptor-reg)) temp)
(:results (result :scs (any-reg) :from (:argument 0))
- (num :scs (any-reg) :from (:argument 0)))
+ (num :scs (any-reg) :from (:argument 0)))
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-return-pc label)
(note-this-location vop :non-local-entry)
(let ((loop (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
;; Setup results, and test for the zero value case.
(load-stack-tn result top)
(def!constant float-round-to-positive 2)
(def!constant float-round-to-negative 3)
-(defconstant-eqx float-rounding-mode (byte 2 30) #'equalp) ; RD
-(defconstant-eqx float-sticky-bits (byte 5 5) #'equalp) ; aexc
-(defconstant-eqx float-traps-byte (byte 5 23) #'equalp) ; TEM
-(defconstant-eqx float-exceptions-byte (byte 5 0) #'equalp) ; cexc
+(defconstant-eqx float-rounding-mode (byte 2 30) #'equalp) ; RD
+(defconstant-eqx float-sticky-bits (byte 5 5) #'equalp) ; aexc
+(defconstant-eqx float-traps-byte (byte 5 23) #'equalp) ; TEM
+(defconstant-eqx float-exceptions-byte (byte 5 0) #'equalp) ; cexc
;;; According to the SPARC doc (as opposed to FPU doc), the fast mode
;;; bit (EFM) is "reserved", and should always be zero. However, for
(progn
(def!constant linkage-table-space-start #x0f800000)
(def!constant linkage-table-space-end #x10000000)
-
+
(def!constant read-only-space-start #x10000000)
(def!constant read-only-space-end #x15000000)
(def!constant dynamic-0-space-start #x30000000)
(def!constant dynamic-0-space-end #x38000000)
-
+
(def!constant dynamic-1-space-start #x40000000)
(def!constant dynamic-1-space-end #x48000000))
(progn
(def!constant linkage-table-space-start #x0f800000)
(def!constant linkage-table-space-end #x10000000)
-
+
(def!constant read-only-space-start #x10000000)
(def!constant read-only-space-end #x15000000)
-
+
(def!constant static-space-start #x28000000)
(def!constant static-space-end #x2c000000)
(def!constant dynamic-0-space-start #x30000000)
(def!constant dynamic-0-space-end #x38000000)
-
+
(def!constant dynamic-1-space-start #x40000000)
(def!constant dynamic-1-space-end #x48000000))
*binding-stack-start*
*control-stack-start*
*control-stack-end*
-
+
;; interrupt handling
*free-interrupt-context-index*
sb!unix::*interrupts-enabled*
(define-vop (if-eq)
(:args (x :scs (any-reg descriptor-reg zero null))
- (y :scs (any-reg descriptor-reg zero null)))
+ (y :scs (any-reg descriptor-reg zero null)))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
;;;; 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.
(defun sanctify-for-execution (component)
(without-gcing
(alien-funcall (extern-alien "os_flush_icache"
- (function void
- system-area-pointer
- unsigned-long))
- (code-instructions component)
- (* (code-header-ref component code-code-size-slot)
- n-word-bytes)))
+ (function void
+ system-area-pointer
+ unsigned-long))
+ (code-instructions component)
+ (* (code-header-ref component code-code-size-slot)
+ n-word-bytes)))
nil)
(:args (sap :scs (sap-reg) :to :save))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:results (res :scs (descriptor-reg)))
- (:note "SAP to pointer coercion")
+ (:note "SAP to pointer coercion")
(:generator 20
(with-fixed-allocation (res ndescr sap-widetag sap-size)
(storew sap res sap-pointer-slot other-pointer-lowtag))))
;;; 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
(define-vop (pointer+)
(:translate sap+)
(:args (ptr :scs (sap-reg))
- (offset :scs (signed-reg)))
+ (offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(define-vop (pointer-)
(:translate sap-)
(:args (ptr1 :scs (sap-reg))
- (ptr2 :scs (sap-reg)))
+ (ptr2 :scs (sap-reg)))
(:arg-types system-area-pointer system-area-pointer)
(:policy :fast-safe)
(:results (res :scs (signed-reg)))
;;;; 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")))
- `(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)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- ,@(if (eql size :long-float)
- '((load-long-reg result sap offset t))
- `((inst ,(ecase size
- (:byte (if signed 'ldsb 'ldub))
- (:short (if signed 'ldsh 'lduh))
- (:long 'ld)
- (:single 'ldf)
- (:double 'lddf))
- result sap offset)))))
- (define-vop (,ref-name-c)
- (:translate ,ref-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg)))
- (:arg-types system-area-pointer (:constant (signed-byte 13)))
- (:info offset)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- ,@(if (eql size :long-float)
- '((load-long-reg result sap offset t))
- `((inst ,(ecase size
- (:byte (if signed 'ldsb 'ldub))
- (:short (if signed 'ldsh 'lduh))
- (:long 'ld)
- (:single 'ldf)
- (:double 'lddf))
- result sap offset)))))
- (define-vop (,set-name)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg))
- (offset :scs (signed-reg))
- (value :scs (,sc) :target result))
- (:arg-types system-area-pointer signed-num ,type)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 5
- ,@(if (eql size :long-float)
- '((store-long-reg value sap offset t))
- `((inst ,(ecase size
- (:byte 'stb)
- (:short 'sth)
- (:long 'st)
- (:single 'stf)
- (:double 'stdf))
- value sap offset)))
- (unless (location= result value)
- ,@(case size
- (:single
- '((inst fmovs result value)))
- (:double
- '((move-double-reg result value)))
- (:long-float
- '((move-long-reg result value)))
- (t
- '((inst move result value)))))))
- (define-vop (,set-name-c)
- (:translate ,set-name)
- (:policy :fast-safe)
- (:args (sap :scs (sap-reg))
- (value :scs (,sc) :target result))
- (:arg-types system-area-pointer (:constant (signed-byte 13)) ,type)
- (:info offset)
- (:results (result :scs (,sc)))
- (:result-types ,type)
- (:generator 4
- ,@(if (eql size :long-float)
- '((store-long-reg value sap offset t))
- `((inst ,(ecase size
- (:byte 'stb)
- (:short 'sth)
- (:long 'st)
- (:single 'stf)
- (:double 'stdf))
- value sap offset)))
- (unless (location= result value)
- ,@(case size
- (:single
- '((inst fmovs result value)))
- (:double
- '((move-double-reg result value)))
- (:long-float
- '((move-long-reg result value)))
- (t
- '((inst move result value)))))))))))
+ (let ((ref-name-c (symbolicate ref-name "-C"))
+ (set-name-c (symbolicate set-name "-C")))
+ `(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)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(if (eql size :long-float)
+ '((load-long-reg result sap offset t))
+ `((inst ,(ecase size
+ (:byte (if signed 'ldsb 'ldub))
+ (:short (if signed 'ldsh 'lduh))
+ (:long 'ld)
+ (:single 'ldf)
+ (:double 'lddf))
+ result sap offset)))))
+ (define-vop (,ref-name-c)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg)))
+ (:arg-types system-area-pointer (:constant (signed-byte 13)))
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ ,@(if (eql size :long-float)
+ '((load-long-reg result sap offset t))
+ `((inst ,(ecase size
+ (:byte (if signed 'ldsb 'ldub))
+ (:short (if signed 'ldsh 'lduh))
+ (:long 'ld)
+ (:single 'ldf)
+ (:double 'lddf))
+ result sap offset)))))
+ (define-vop (,set-name)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (offset :scs (signed-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer signed-num ,type)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(if (eql size :long-float)
+ '((store-long-reg value sap offset t))
+ `((inst ,(ecase size
+ (:byte 'stb)
+ (:short 'sth)
+ (:long 'st)
+ (:single 'stf)
+ (:double 'stdf))
+ value sap offset)))
+ (unless (location= result value)
+ ,@(case size
+ (:single
+ '((inst fmovs result value)))
+ (:double
+ '((move-double-reg result value)))
+ (:long-float
+ '((move-long-reg result value)))
+ (t
+ '((inst move result value)))))))
+ (define-vop (,set-name-c)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer (:constant (signed-byte 13)) ,type)
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ ,@(if (eql size :long-float)
+ '((store-long-reg value sap offset t))
+ `((inst ,(ecase size
+ (:byte 'stb)
+ (:short 'sth)
+ (:long 'st)
+ (:single 'stf)
+ (:double 'stdf))
+ value sap offset)))
+ (unless (location= result value)
+ ,@(case size
+ (:single
+ '((inst fmovs result value)))
+ (:double
+ '((move-double-reg result value)))
+ (:long-float
+ '((move-long-reg result value)))
+ (t
+ '((inst move result value)))))))))))
(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
unsigned-reg positive-fixnum :byte nil)
(:result-types system-area-pointer)
(:generator 2
(inst add sap vector
- (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
+ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
\f
;;; Transforms for 64-bit SAP accessors.
(deftransform sap-ref-64 ((sap offset) (* *))
'(logior (ash (sap-ref-32 sap offset) 32)
- (sap-ref-32 sap (+ offset 4))))
+ (sap-ref-32 sap (+ offset 4))))
(deftransform signed-sap-ref-64 ((sap offset) (* *))
'(logior (ash (signed-sap-ref-32 sap offset) 32)
- (sap-ref-32 sap (+ 4 offset))))
+ (sap-ref-32 sap (+ 4 offset))))
(deftransform %set-sap-ref-64 ((sap offset value) (* * *))
'(progn
(:generator 100
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(move nl0 object)
(inst li cfunc (make-fixup "debug_print" :foreign))
(inst li temp (make-fixup "call_into_c" :foreign))
(inst jal lip temp)
(inst nop)
(when cur-nfp
- (load-stack-tn cur-nfp nfp-save))
+ (load-stack-tn cur-nfp nfp-save))
(move result nl0))))
(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*)
- ,@(when (< i num-args)
- `(:from (:argument ,i)))
- ,@(when (< i num-results)
- `(:to (:result ,i)
- :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*)
+ ,@(when (< i num-args)
+ `(:from (:argument ,i)))
+ ,@(when (< i num-results)
+ `(:to (:result ,i)
+ :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)
- (let ((lra-label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
- ,@(moves (temp-names) (arg-names))
- (inst ld func null-tn (static-fun-offset symbol))
- (inst li nargs (fixnumize ,num-args))
- (when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
- (inst move old-fp cfp-tn)
- (inst move cfp-tn csp-tn)
- (inst compute-lra-from-code lra code-tn lra-label temp)
- (note-this-location vop :call-site)
- (inst j func (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag))
- (inst move code-tn func)
- (emit-return-pc lra-label)
- ,(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 move-temp temp lra-label)))
- (when cur-nfp
- (load-stack-tn cur-nfp nfp-save))
- ,@(moves (result-names) (temp-names))))))))
+ static-fun-template)
+ (:args ,@(args))
+ ,@(temps)
+ (:results ,@(results))
+ (:generator ,(+ 50 num-args num-results)
+ (let ((lra-label (gen-label))
+ (cur-nfp (current-nfp-tn vop)))
+ ,@(moves (temp-names) (arg-names))
+ (inst ld func null-tn (static-fun-offset symbol))
+ (inst li nargs (fixnumize ,num-args))
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (inst move old-fp cfp-tn)
+ (inst move cfp-tn csp-tn)
+ (inst compute-lra-from-code lra code-tn lra-label temp)
+ (note-this-location vop :call-site)
+ (inst j func (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag))
+ (inst move code-tn func)
+ (emit-return-pc lra-label)
+ ,(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 move-temp temp lra-label)))
+ (when cur-nfp
+ (load-stack-tn cur-nfp nfp-save))
+ ,@(moves (result-names) (temp-names))))))))
) ; EVAL-WHEN
;;; FIXME! This looks like a candidate for a dotimes to
;;; register-arg-count.
(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 5 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)))))
(:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
- count)
+ count)
(:results (result :scs (any-reg descriptor-reg)))
(:policy :fast-safe)
(:vop-var vop)
(:save-p :compute-only)
(:generator 50
(let ((done (gen-label))
- (loop (gen-label))
- (not-list (generate-cerror-code vop object-not-list-error object)))
+ (loop (gen-label))
+ (not-list (generate-cerror-code vop object-not-list-error object)))
(move ptr object)
(move count zero-tn)
(emit-label done)
(move result count))))
-
+
(define-static-fun length (object) :translate length)
;; It wasn't a fixnum, so get the low 8 bits.
(inst b done)
(inst and result object widetag-mask)
-
+
FUNCTION-POINTER
(inst b done)
(load-type result object (- fun-pointer-lowtag))
(:translate (setf fun-subtype))
(:policy :fast-safe)
(:args (type :scs (unsigned-reg) :target result)
- (function :scs (descriptor-reg)))
+ (function :scs (descriptor-reg)))
(:arg-types positive-fixnum *)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:translate set-header-data)
(:policy :fast-safe)
(:args (x :scs (descriptor-reg) :target res)
- (data :scs (any-reg immediate zero)))
+ (data :scs (any-reg immediate zero)))
(:arg-types * positive-fixnum)
(:results (res :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) t1 t2)
(define-vop (make-other-immediate-type)
(:args (val :scs (any-reg descriptor-reg))
- (type :scs (any-reg descriptor-reg immediate)
- :target temp))
+ (type :scs (any-reg descriptor-reg immediate)
+ :target temp))
(:results (res :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 2
(define-vop (compute-fun)
(:args (code :scs (descriptor-reg))
- (offset :scs (signed-reg unsigned-reg)))
+ (offset :scs (signed-reg unsigned-reg)))
(:arg-types * positive-fixnum)
(:results (func :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (non-descriptor-reg)) count)
(:generator 1
(let ((offset
- (- (* (+ index vector-data-offset) n-word-bytes)
- other-pointer-lowtag)))
+ (- (* (+ index vector-data-offset) n-word-bytes)
+ other-pointer-lowtag)))
(aver (typep offset '(signed-byte 13)))
(inst ld count count-vector offset)
(inst add count 1)
(assemble ()
(inst andcc zero-tn value fixnum-tag-mask)
(if (member :sparc-v9 *backend-subfeatures*)
- (inst b (if not-p :ne :eq) target (if not-p :pn :pt))
- (inst b (if not-p :ne :eq) target))
+ (inst b (if not-p :ne :eq) target (if not-p :pn :pt))
+ (inst b (if not-p :ne :eq) target))
(inst nop)))
(defun %test-fixnum-and-headers (value target not-p headers
- &key temp)
+ &key temp)
(let ((drop-through (gen-label)))
(assemble ()
(inst andcc zero-tn value fixnum-tag-mask)
(inst b :eq (if not-p drop-through target)))
(%test-headers value target not-p nil headers
- :drop-through drop-through
- :temp temp)))
+ :drop-through drop-through
+ :temp temp)))
(defun %test-immediate (value target not-p immediate &key temp)
(assemble ()
(inst nop)))
(defun %test-lowtag (value target not-p lowtag
- &key temp skip-nop)
+ &key temp skip-nop)
(assemble ()
(inst and temp value lowtag-mask)
(inst cmp temp lowtag)
(inst nop))))
(defun %test-headers (value target not-p function-p headers
- &key temp (drop-through (gen-label)))
+ &key temp (drop-through (gen-label)))
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind (when-true when-false)
- (if not-p
- (values drop-through target)
- (values target drop-through))
+ (if not-p
+ (values drop-through target)
+ (values target drop-through))
(assemble ()
- (%test-lowtag value when-false t lowtag :temp temp)
- (load-type temp value (- 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))
- (inst and temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
- (inst cmp temp (ldb (byte 8 0) (logand header (cadr remaining))))
- (inst b (if not-p :ne :eq) target)
- (return))
- (t
- (inst cmp temp header)
- (if last
- ;; FIXME: Some SPARC-V9 magic might not go amiss
- ;; here, too, if I can figure out what it should
- ;; be.
- (inst b (if not-p :ne :eq) target)
- (inst b :eq when-true)))))
- (t
- (let ((start (car header))
- (end (cdr header)))
- ;; FIXME: BIGNUM-WIDETAG here actually means (MIN
- ;; <widetags>).
- (cond
- ;; FIXME: this doesn't catch the {0x2 0x6 0xA 0xE}
- ;; group
- ;;
- ;; also FIXME: exuberant cut'n'paste between
- ;; backends
- ((and last (not (= start bignum-widetag))
- (= (+ start 4) end)
- (= (logcount (logxor start end)) 1))
- (inst and temp temp (ldb (byte 8 0) (logeqv start end)))
- (inst cmp temp (ldb (byte 8 0) (logand start end)))
- (inst b (if not-p :ne :eq) 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))
- (inst and temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
- (inst cmp temp (ldb (byte 8 0) (logand start (cdadr remaining))))
- (inst b (if not-p :ne :eq) target)
- (return))
- (t
- (unless (= start bignum-widetag)
- (inst cmp temp start)
- (if (= end complex-array-widetag)
- (progn
- (aver last)
- (inst b (if not-p :lt :ge) target))
- (inst b :lt when-false)))
- (unless (= end complex-array-widetag)
- (inst cmp temp end)
- (if last
- (inst b (if not-p :gt :le) target)
- (inst b :le when-true))))))))))
- (inst nop)
- (emit-label drop-through)))))
+ (%test-lowtag value when-false t lowtag :temp temp)
+ (load-type temp value (- 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))
+ (inst and temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
+ (inst cmp temp (ldb (byte 8 0) (logand header (cadr remaining))))
+ (inst b (if not-p :ne :eq) target)
+ (return))
+ (t
+ (inst cmp temp header)
+ (if last
+ ;; FIXME: Some SPARC-V9 magic might not go amiss
+ ;; here, too, if I can figure out what it should
+ ;; be.
+ (inst b (if not-p :ne :eq) target)
+ (inst b :eq when-true)))))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ ;; FIXME: BIGNUM-WIDETAG here actually means (MIN
+ ;; <widetags>).
+ (cond
+ ;; FIXME: this doesn't catch the {0x2 0x6 0xA 0xE}
+ ;; group
+ ;;
+ ;; also FIXME: exuberant cut'n'paste between
+ ;; backends
+ ((and last (not (= start bignum-widetag))
+ (= (+ start 4) end)
+ (= (logcount (logxor start end)) 1))
+ (inst and temp temp (ldb (byte 8 0) (logeqv start end)))
+ (inst cmp temp (ldb (byte 8 0) (logand start end)))
+ (inst b (if not-p :ne :eq) 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))
+ (inst and temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
+ (inst cmp temp (ldb (byte 8 0) (logand start (cdadr remaining))))
+ (inst b (if not-p :ne :eq) target)
+ (return))
+ (t
+ (unless (= start bignum-widetag)
+ (inst cmp temp start)
+ (if (= end complex-array-widetag)
+ (progn
+ (aver last)
+ (inst b (if not-p :lt :ge) target))
+ (inst b :lt when-false)))
+ (unless (= end complex-array-widetag)
+ (inst cmp temp end)
+ (if last
+ (inst b (if not-p :gt :le) target)
+ (inst b :le when-true))))))))))
+ (inst nop)
+ (emit-label drop-through)))))
;;;; Simple type checking and testing:
;;;
(if (> (apply #'max type-codes) lowtag-limit) 7 2)))
(defmacro !define-type-vops (pred-name check-name ptype error-code
- (&rest type-codes)
- &key &allow-other-keys)
+ (&rest type-codes)
+ &key &allow-other-keys)
(let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
`(progn
,@(when pred-name
- `((define-vop (,pred-name type-predicate)
- (:translate ,pred-name)
- (:generator ,cost
- (test-type value target not-p (,@type-codes)
- :temp temp)))))
+ `((define-vop (,pred-name type-predicate)
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value target not-p (,@type-codes)
+ :temp temp)))))
,@(when check-name
- `((define-vop (,check-name check-type)
- (:generator ,cost
- (let ((err-lab
- (generate-error-code vop ,error-code value)))
- (test-type value err-lab t (,@type-codes)
- :temp temp)
- (move result value))))))
+ `((define-vop (,check-name check-type)
+ (:generator ,cost
+ (let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value err-lab t (,@type-codes)
+ :temp temp)
+ (move result value))))))
,@(when ptype
- `((primitive-type-vop ,check-name (:check) ,ptype))))))
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
\f
;;;; Other integer ranges.
(define-vop (signed-byte-32-p type-predicate)
(:translate signed-byte-32-p)
(:generator 45
- (let ((not-target (gen-label)))
- (multiple-value-bind
- (yep nope)
- (if not-p
- (values not-target target)
- (values target not-target))
- (inst andcc zero-tn value #x3)
- (inst b :eq yep)
- (test-type value nope t (other-pointer-lowtag) :temp temp)
- (loadw temp value 0 other-pointer-lowtag)
- (inst cmp temp (+ (ash 1 n-widetag-bits)
- bignum-widetag))
- (inst b (if not-p :ne :eq) target)
- (inst nop)
- (emit-label not-target)))))
+ (let ((not-target (gen-label)))
+ (multiple-value-bind
+ (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ (inst andcc zero-tn value #x3)
+ (inst b :eq yep)
+ (test-type value nope t (other-pointer-lowtag) :temp temp)
+ (loadw temp value 0 other-pointer-lowtag)
+ (inst cmp temp (+ (ash 1 n-widetag-bits)
+ bignum-widetag))
+ (inst b (if not-p :ne :eq) target)
+ (inst nop)
+ (emit-label not-target)))))
(define-vop (check-signed-byte-32 check-type)
(:generator 45
- (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
- (yep (gen-label)))
- (inst andcc temp value #x3)
- (inst b :eq yep)
- (test-type value nope t (other-pointer-lowtag) :temp temp)
- (loadw temp value 0 other-pointer-lowtag)
- (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
- (inst b :ne nope)
- (inst nop)
- (emit-label yep)
- (move result value))))
+ (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
+ (yep (gen-label)))
+ (inst andcc temp value #x3)
+ (inst b :eq yep)
+ (test-type value nope t (other-pointer-lowtag) :temp temp)
+ (loadw temp value 0 other-pointer-lowtag)
+ (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (inst b :ne nope)
+ (inst nop)
+ (emit-label yep)
+ (move result value))))
;; An (unsigned-byte 32) can be represented with either a
(define-vop (unsigned-byte-32-p type-predicate)
(:translate unsigned-byte-32-p)
(:generator 45
- (let ((not-target (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?
- (inst andcc temp value #x3)
- (inst b :eq fixnum)
- (inst cmp value)
-
- ;; If not, is it an other pointer?
- (test-type value nope t (other-pointer-lowtag) :temp temp)
- ;; Get the header.
- (loadw temp value 0 other-pointer-lowtag)
- ;; Is it one?
- (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
- (inst b :eq single-word)
- ;; If it's other than two, we can't be an
- ;; (unsigned-byte 32)
- (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
- (inst b :ne nope)
- ;; Get the second digit.
- (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
- ;; All zeros, its an (unsigned-byte 32).
- (inst cmp temp)
- (inst b :eq yep)
- (inst nop)
- ;; Otherwise, it isn't.
- (inst b nope)
- (inst nop)
-
- (emit-label single-word)
- ;; Get the single digit.
- (loadw temp value bignum-digits-offset other-pointer-lowtag)
- (inst cmp temp)
-
- ;; positive implies (unsigned-byte 32).
- (emit-label fixnum)
- (inst b (if not-p :lt :ge) target)
- (inst nop)
-
- (emit-label not-target)))))
+ (let ((not-target (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?
+ (inst andcc temp value #x3)
+ (inst b :eq fixnum)
+ (inst cmp value)
+
+ ;; If not, is it an other pointer?
+ (test-type value nope t (other-pointer-lowtag) :temp temp)
+ ;; Get the header.
+ (loadw temp value 0 other-pointer-lowtag)
+ ;; Is it one?
+ (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (inst b :eq single-word)
+ ;; If it's other than two, we can't be an
+ ;; (unsigned-byte 32)
+ (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
+ (inst b :ne nope)
+ ;; Get the second digit.
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
+ ;; All zeros, its an (unsigned-byte 32).
+ (inst cmp temp)
+ (inst b :eq yep)
+ (inst nop)
+ ;; Otherwise, it isn't.
+ (inst b nope)
+ (inst nop)
+
+ (emit-label single-word)
+ ;; Get the single digit.
+ (loadw temp value bignum-digits-offset other-pointer-lowtag)
+ (inst cmp temp)
+
+ ;; positive implies (unsigned-byte 32).
+ (emit-label fixnum)
+ (inst b (if not-p :lt :ge) target)
+ (inst nop)
+
+ (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)))
- ;; Is it a fixnum?
- (inst andcc temp value #x3)
- (inst b :eq fixnum)
- (inst cmp value)
-
- ;; If not, is it an other pointer?
- (test-type value nope t (other-pointer-lowtag) :temp temp)
- ;; Get the number of digits.
- (loadw temp value 0 other-pointer-lowtag)
- ;; Is it one?
- (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
- (inst b :eq single-word)
- ;; If it's other than two, we can't be an (unsigned-byte 32)
- (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
- (inst b :ne nope)
- ;; Get the second digit.
- (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
- ;; All zeros, its an (unsigned-byte 32).
- (inst cmp temp)
- (inst b :eq yep)
- ;; Otherwise, it isn't.
- (inst b :ne nope)
- (inst nop)
-
- (emit-label single-word)
- ;; Get the single digit.
- (loadw temp value bignum-digits-offset other-pointer-lowtag)
- ;; positive implies (unsigned-byte 32).
- (inst cmp temp)
-
- (emit-label fixnum)
- (inst b :lt nope)
- (inst nop)
-
- (emit-label yep)
- (move result value))))
+ (let ((nope
+ (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?
+ (inst andcc temp value #x3)
+ (inst b :eq fixnum)
+ (inst cmp value)
+
+ ;; If not, is it an other pointer?
+ (test-type value nope t (other-pointer-lowtag) :temp temp)
+ ;; Get the number of digits.
+ (loadw temp value 0 other-pointer-lowtag)
+ ;; Is it one?
+ (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
+ (inst b :eq single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 32)
+ (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
+ (inst b :ne nope)
+ ;; Get the second digit.
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
+ ;; All zeros, its an (unsigned-byte 32).
+ (inst cmp temp)
+ (inst b :eq yep)
+ ;; Otherwise, it isn't.
+ (inst b :ne nope)
+ (inst nop)
+
+ (emit-label single-word)
+ ;; Get the single digit.
+ (loadw temp value bignum-digits-offset other-pointer-lowtag)
+ ;; positive implies (unsigned-byte 32).
+ (inst cmp temp)
+
+ (emit-label fixnum)
+ (inst b :lt nope)
+ (inst nop)
+
+ (emit-label yep)
+ (move result value))))
\f
;; symbolp (or symbol (eq nil))
;; consp (and list (not (eq nil)))
-
+
(define-vop (symbolp type-predicate)
(:translate symbolp)
(:generator 12
- (let* ((drop-thru (gen-label))
- (is-symbol-label (if not-p drop-thru target)))
- (inst cmp value null-tn)
- (inst b :eq is-symbol-label)
- (test-type value target not-p (symbol-header-widetag) :temp temp)
- (emit-label drop-thru))))
-
+ (let* ((drop-thru (gen-label))
+ (is-symbol-label (if not-p drop-thru target)))
+ (inst cmp value null-tn)
+ (inst b :eq is-symbol-label)
+ (test-type value target not-p (symbol-header-widetag) :temp temp)
+ (emit-label drop-thru))))
+
(define-vop (check-symbol check-type)
(:generator 12
- (let ((drop-thru (gen-label))
- (error (generate-error-code vop object-not-symbol-error value)))
- (inst cmp value null-tn)
- (inst b :eq drop-thru)
- (test-type value error t (symbol-header-widetag) :temp temp)
- (emit-label drop-thru)
- (move result value))))
-
+ (let ((drop-thru (gen-label))
+ (error (generate-error-code vop object-not-symbol-error value)))
+ (inst cmp value null-tn)
+ (inst b :eq drop-thru)
+ (test-type value error t (symbol-header-widetag) :temp temp)
+ (emit-label drop-thru)
+ (move result value))))
+
(define-vop (consp type-predicate)
(:translate consp)
(:generator 8
- (let* ((drop-thru (gen-label))
- (is-not-cons-label (if not-p target drop-thru)))
- (inst cmp value null-tn)
- (inst b :eq is-not-cons-label)
- (test-type value target not-p (list-pointer-lowtag) :temp temp)
- (emit-label drop-thru))))
-
+ (let* ((drop-thru (gen-label))
+ (is-not-cons-label (if not-p target drop-thru)))
+ (inst cmp value null-tn)
+ (inst b :eq is-not-cons-label)
+ (test-type value target not-p (list-pointer-lowtag) :temp temp)
+ (emit-label drop-thru))))
+
(define-vop (check-cons check-type)
(:generator 8
- (let ((error (generate-error-code vop object-not-cons-error value)))
- (inst cmp value null-tn)
- (inst b :eq error)
- (test-type value error t (list-pointer-lowtag) :temp temp)
- (move result value))))
+ (let ((error (generate-error-code vop object-not-cons-error value)))
+ (inst cmp value null-tn)
+ (inst b :eq error)
+ (test-type value error t (list-pointer-lowtag) :temp temp)
+ (move result value))))
(define-vop (%%nip-dx)
(:args (last-nipped-ptr :scs (any-reg) :target dest)
- (last-preserved-ptr :scs (any-reg) :target src)
- (moved-ptrs :scs (any-reg) :more t))
+ (last-preserved-ptr :scs (any-reg) :target src)
+ (moved-ptrs :scs (any-reg) :more t))
(:results (r-moved-ptrs :scs (any-reg) :more t))
(:temporary (:sc any-reg) src)
(:temporary (:sc any-reg) dest)
(define-vop (push-values)
(:args (vals :more t))
(:results (start :scs (any-reg) :from :load)
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:info nvals)
(:temporary (:scs (descriptor-reg)) temp)
(:generator 20
(inst move start csp-tn)
(inst add csp-tn csp-tn (* nvals n-word-bytes))
(do ((val vals (tn-ref-across val))
- (i 0 (1+ i)))
- ((null val))
+ (i 0 (1+ i)))
+ ((null val))
(let ((tn (tn-ref-tn val)))
- (sc-case tn
- (descriptor-reg
- (storew tn start i))
- (control-stack
- (load-stack-tn temp tn)
- (storew temp start i)))))
+ (sc-case tn
+ (descriptor-reg
+ (storew tn start i))
+ (control-stack
+ (load-stack-tn temp tn)
+ (storew temp start i)))))
(inst li count (fixnumize nvals))))
;;; Push a list of values on the stack, returning Start and Count as
(:arg-types list)
(:policy :fast-safe)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:save-p :compute-only)
(:generator 0
(let ((loop (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(move list arg)
(move start csp-tn)
;;; as function arguments.
(define-vop (%more-arg-values)
(:args (context :scs (descriptor-reg any-reg) :target src)
- (skip :scs (any-reg zero immediate))
- (num :scs (any-reg) :target count))
+ (skip :scs (any-reg zero immediate))
+ (num :scs (any-reg) :target count))
(:arg-types * positive-fixnum positive-fixnum)
(:temporary (:sc any-reg :from (:argument 0)) src)
(:temporary (:sc any-reg :from (:argument 2)) dst)
(:temporary (:sc descriptor-reg :from (:argument 1)) temp)
(:temporary (:sc any-reg) i)
(:results (start :scs (any-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:generator 20
(sc-case skip
(zero
(defvar *register-names* (make-array 32 :initial-element nil)))
(macrolet ((defreg (name offset)
- (let ((offset-sym (symbolicate name "-OFFSET")))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (def!constant ,offset-sym ,offset)
- (setf (svref *register-names* ,offset-sym)
- ,(symbol-name name)))))
-
- (defregset (name &rest regs)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter ,name
- (list ,@(mapcar (lambda (name)
- (symbolicate name "-OFFSET"))
- regs))))))
+ (let ((offset-sym (symbolicate name "-OFFSET")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def!constant ,offset-sym ,offset)
+ (setf (svref *register-names* ,offset-sym)
+ ,(symbol-name name)))))
+
+ (defregset (name &rest regs)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter ,name
+ (list ,@(mapcar (lambda (name)
+ (symbolicate name "-OFFSET"))
+ regs))))))
;; c.f. src/runtime/sparc-lispregs.h
;; Globals. These are difficult to extract from a sigcontext.
- (defreg zero 0) ; %g0
- (defreg alloc 1) ; %g1
- (defreg null 2) ; %g2
- (defreg csp 3) ; %g3
- (defreg cfp 4) ; %g4
- (defreg bsp 5) ; %g5
+ (defreg zero 0) ; %g0
+ (defreg alloc 1) ; %g1
+ (defreg null 2) ; %g2
+ (defreg csp 3) ; %g3
+ (defreg cfp 4) ; %g4
+ (defreg bsp 5) ; %g5
;; %g6 and %g7 are supposed to be reserved for the system.
;; Outs. These get clobbered when we call into C.
- (defreg nl0 8) ; %o0
- (defreg nl1 9) ; %o1
- (defreg nl2 10) ; %o2
- (defreg nl3 11) ; %o3
- (defreg nl4 12) ; %o4
- (defreg nl5 13) ; %o5
- (defreg nsp 14) ; %o6
- (defreg nargs 15) ; %o7
+ (defreg nl0 8) ; %o0
+ (defreg nl1 9) ; %o1
+ (defreg nl2 10) ; %o2
+ (defreg nl3 11) ; %o3
+ (defreg nl4 12) ; %o4
+ (defreg nl5 13) ; %o5
+ (defreg nsp 14) ; %o6
+ (defreg nargs 15) ; %o7
;; Locals. These are preserved when we call into C.
- (defreg a0 16) ; %l0
- (defreg a1 17) ; %l1
- (defreg a2 18) ; %l2
- (defreg a3 19) ; %l3
- (defreg a4 20) ; %l4
- (defreg a5 21) ; %l5
- (defreg ocfp 22) ; %l6
- (defreg lra 23) ; %l7
+ (defreg a0 16) ; %l0
+ (defreg a1 17) ; %l1
+ (defreg a2 18) ; %l2
+ (defreg a3 19) ; %l3
+ (defreg a4 20) ; %l4
+ (defreg a5 21) ; %l5
+ (defreg ocfp 22) ; %l6
+ (defreg lra 23) ; %l7
;; Ins. These are preserved just like locals.
- (defreg cname 24) ; %i0
- (defreg lexenv 25) ; %i1
- (defreg l0 26) ; %i2
- (defreg nfp 27) ; %i3
- (defreg cfunc 28) ; %i4
- (defreg code 29) ; %i5
+ (defreg cname 24) ; %i0
+ (defreg lexenv 25) ; %i1
+ (defreg l0 26) ; %i2
+ (defreg nfp 27) ; %i3
+ (defreg cfunc 28) ; %i4
+ (defreg code 29) ; %i5
;; we can't touch reg 30 if we ever want to return
- (defreg lip 31) ; %i7
+ (defreg lip 31) ; %i7
(defregset non-descriptor-regs
nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp)
-
+
(defregset descriptor-regs
a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv l0)
;;; whenever we insert a new storage class
(defmacro !define-storage-classes (&rest classes)
(do ((forms (list 'progn)
- (let* ((class (car classes))
- (sc-name (car class))
- (constant-name (intern (concatenate 'simple-string
- (string sc-name)
- "-SC-NUMBER"))))
- (list* `(define-storage-class ,sc-name ,index
- ,@(cdr class))
- `(def!constant ,constant-name ,index)
+ (let* ((class (car classes))
+ (sc-name (car class))
+ (constant-name (intern (concatenate 'simple-string
+ (string sc-name)
+ "-SC-NUMBER"))))
+ (list* `(define-storage-class ,sc-name ,index
+ ,@(cdr class))
+ `(def!constant ,constant-name ,index)
;; (The CMU CL version of this macro did
;; `(EXPORT ',CONSTANT-NAME)
;; here, but in SBCL we try to have package
;; master source file, instead of building it
;; dynamically by letting all the system code
;; modify it as the system boots.)
- forms)))
+ forms)))
(index 0 (1+ index))
(classes classes (cdr classes)))
((null classes)
(sap-stack non-descriptor-stack) ; System area pointers.
(single-stack non-descriptor-stack) ; single-floats
(double-stack non-descriptor-stack
- :element-size 2 :alignment 2) ; double floats.
+ :element-size 2 :alignment 2) ; double floats.
#!+long-float
(long-stack non-descriptor-stack :element-size 4 :alignment 4) ; long floats.
;; complex-single-floats
;; Non-Descriptor double-floats.
(double-reg float-registers
:locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
- by 2 collect i)
+ by 2 collect i)
:element-size 2 :alignment 2
:reserve-locations (28 30)
:constant-scs ()
#!+long-float
(long-reg float-registers
:locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
- by 4 collect i)
+ by 4 collect i)
:element-size 4 :alignment 4
:reserve-locations (28)
:constant-scs ()
(complex-double-reg float-registers
:locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
- by 4 collect i)
+ by 4 collect i)
:element-size 4 :alignment 4
:reserve-locations (28)
:constant-scs ()
#!+long-float
(complex-long-reg float-registers
:locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
- by 8 collect i)
+ by 8 collect i)
:element-size 8 :alignment 8
:constant-scs ()
:save-p t
\f
;;;; Make some miscellaneous TNs for important registers.
(macrolet ((defregtn (name sc)
- (let ((offset-sym (symbolicate name "-OFFSET"))
- (tn-sym (symbolicate name "-TN")))
- `(defparameter ,tn-sym
- (make-random-tn :kind :normal
- :sc (sc-or-lose ',sc)
- :offset ,offset-sym)))))
+ (let ((offset-sym (symbolicate name "-OFFSET"))
+ (tn-sym (symbolicate name "-TN")))
+ `(defparameter ,tn-sym
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose ',sc)
+ :offset ,offset-sym)))))
(defregtn zero any-reg)
(defregtn null descriptor-reg)
(defregtn code descriptor-reg)
(defregtn alloc any-reg)
-
+
(defregtn nargs any-reg)
(defregtn bsp any-reg)
(defregtn csp any-reg)
(null
(sc-number-or-lose 'null))
((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
- system-area-pointer character)
+ system-area-pointer character)
(sc-number-or-lose 'immediate))
(symbol
(if (static-symbol-p value)
- (sc-number-or-lose 'immediate)
- nil))))
+ (sc-number-or-lose 'immediate)
+ nil))))
\f
;;;; function call parameters
;;; a list of TN's describing the register arguments
(defparameter *register-arg-tns*
(mapcar (lambda (n)
- (make-random-tn :kind :normal
- :sc (sc-or-lose 'descriptor-reg)
- :offset n))
- *register-arg-offsets*))
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset n))
+ *register-arg-offsets*))
;;; This is used by the debugger.
(def!constant single-value-return-byte-offset 8)
(!def-vm-support-routine location-print-name (tn)
(declare (type tn tn)) ; FIXME: commented out on alpha
(let ((sb (sb-name (sc-sb (tn-sc tn))))
- (offset (tn-offset tn)))
+ (offset (tn-offset tn)))
(ecase sb
(registers (or (svref *register-names* offset)
- (format nil "R~D" offset)))
+ (format nil "R~D" offset)))
(float-registers (format nil "F~D" offset))
(control-stack (format nil "CS~D" offset))
(non-descriptor-stack (format nil "NS~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.44"
+"0.9.2.45"
projects / sbcl.git / commitdiff