(defun my-make-wired-tn (prim-type-name sc-name offset)
(make-wired-tn (primitive-type-or-lose prim-type-name)
- (sc-number-or-lose sc-name)
- offset))
+ (sc-number-or-lose sc-name)
+ offset))
(defstruct (arg-state (:copier nil))
(register-args 0)
(defun int-arg (state prim-type reg-sc stack-sc)
(let ((reg-args (arg-state-register-args state)))
(cond ((< reg-args 6)
- (setf (arg-state-register-args state) (1+ reg-args))
- (my-make-wired-tn prim-type reg-sc
- (nth reg-args *c-call-register-arg-offsets*)))
- (t
- (let ((frame-size (arg-state-stack-frame-size state)))
- (setf (arg-state-stack-frame-size state) (1+ frame-size))
- (my-make-wired-tn prim-type stack-sc frame-size))))))
+ (setf (arg-state-register-args state) (1+ reg-args))
+ (my-make-wired-tn prim-type reg-sc
+ (nth reg-args *c-call-register-arg-offsets*)))
+ (t
+ (let ((frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ frame-size))
+ (my-make-wired-tn prim-type stack-sc frame-size))))))
(define-alien-type-method (integer :arg-tn) (type state)
(if (alien-integer-type-signed type)
(defun float-arg (state prim-type reg-sc stack-sc)
(let ((xmm-args (arg-state-xmm-args state)))
(cond ((< xmm-args 8)
- (setf (arg-state-xmm-args state) (1+ xmm-args))
- (my-make-wired-tn prim-type reg-sc
- (nth xmm-args *float-regs*)))
- (t
- (let ((frame-size (arg-state-stack-frame-size state)))
- (setf (arg-state-stack-frame-size state) (1+ frame-size))
- (my-make-wired-tn prim-type stack-sc frame-size))))))
+ (setf (arg-state-xmm-args state) (1+ xmm-args))
+ (my-make-wired-tn prim-type reg-sc
+ (nth xmm-args *float-regs*)))
+ (t
+ (let ((frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ frame-size))
+ (my-make-wired-tn prim-type stack-sc frame-size))))))
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(multiple-value-bind (ptype reg-sc)
- (if (alien-integer-type-signed type)
- (values 'signed-byte-64 'signed-reg)
- (values 'unsigned-byte-64 'unsigned-reg))
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-64 'signed-reg)
+ (values 'unsigned-byte-64 'unsigned-reg))
(my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
(define-alien-type-method (integer :naturalize-gen) (type alien)
(if (and (alien-integer-type-signed type)
- (<= (alien-type-bits type) 32))
+ (<= (alien-type-bits type) 32))
`(sign-extend ,alien)
alien))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'system-area-pointer 'sap-reg
- (result-reg-offset num-results))))
+ (result-reg-offset num-results))))
(define-alien-type-method (double-float :result-tn) (type state)
(declare (ignore type))
(when (> (length values) 2)
(error "Too many result values from c-call."))
(mapcar (lambda (type)
- (invoke-alien-type-method :result-tn type state))
- values)))
+ (invoke-alien-type-method :result-tn type state))
+ values)))
(!def-vm-support-routine make-call-out-tns (type)
(let ((arg-state (make-arg-state)))
(collect ((arg-tns))
(dolist (arg-type (alien-fun-type-arg-types type))
- (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+ (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset)
- (* (arg-state-stack-frame-size arg-state) n-word-bytes)
- (arg-tns)
- (invoke-alien-type-method :result-tn
- (alien-fun-type-result-type type)
- (make-result-state))))))
+ (* (arg-state-stack-frame-size arg-state) n-word-bytes)
+ (arg-tns)
+ (invoke-alien-type-method :result-tn
+ (alien-fun-type-result-type type)
+ (make-result-state))))))
(deftransform %alien-funcall ((function type &rest args) * * :node node)
(aver (sb!c::constant-lvar-p type))
(let* ((type (sb!c::lvar-value type))
- (env (sb!c::node-lexenv node))
+ (env (sb!c::node-lexenv node))
(arg-types (alien-fun-type-arg-types type))
(result-type (alien-fun-type-result-type type)))
(aver (= (length arg-types) (length args)))
(if (alien-integer-type-signed result-type)
'(values (unsigned 64) (signed 64))
'(values (unsigned 64) (unsigned 64)))
- env))))
+ env))))
`(lambda (function type ,@(lambda-vars))
(declare (ignore type))
(multiple-value-bind (low high)
;;; The ABI specifies that signed short/int's are returned as 32-bit
;;; values. Negative values need to be sign-extended to 64-bits (done
;;; in a :NATURALIZE-GEN alien-type-method).
-(defknown sign-extend (fixnum) fixnum (foldable flushable movable))
+(defknown sign-extend (fixnum) fixnum (foldable flushable movable))
(define-vop (sign-extend)
(:translate sign-extend)
(:result-types fixnum)
(:generator 1
(inst movsxd res
- (make-random-tn :kind :normal
- :sc (sc-or-lose 'dword-reg)
- :offset (tn-offset val)))))
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'dword-reg)
+ :offset (tn-offset val)))))
(defun sign-extend (x)
(if (logbitp 31 x)
(dpb x (byte 32 0) -1)
(ldb (byte 32 0) x)))
-(define-vop (foreign-symbol-address)
- (:translate foreign-symbol-address)
+(define-vop (foreign-symbol-sap)
+ (:translate foreign-symbol-sap)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
- (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
+ (inst lea res (make-fixup foreign-symbol :foreign))))
#!+linkage-table
-(define-vop (foreign-symbol-dataref-address)
- (:translate foreign-symbol-dataref-address)
+(define-vop (foreign-symbol-dataref-sap)
+ (:translate foreign-symbol-dataref-sap)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
- (inst mov res (make-fixup (extern-alien-name foreign-symbol) :foreign-dataref))))
+ (inst mov res (make-fixup foreign-symbol :foreign-dataref))))
(define-vop (call-out)
(:args (function :scs (sap-reg))
- (args :more t))
+ (args :more t))
(:results (results :more t))
(:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax)
- (:temporary (:sc unsigned-reg :offset rcx-offset
- :from :eval :to :result) rcx)
(:ignore results)
(:vop-var vop)
(:save-p t)
;; ABI: AL contains amount of arguments passed in XMM registers
;; for vararg calls.
(move-immediate rax
- (loop for tn-ref = args then (tn-ref-across tn-ref)
- while tn-ref
- count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref))))
- 'float-registers)))
+ (loop for tn-ref = args then (tn-ref-across tn-ref)
+ while tn-ref
+ count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref))))
+ 'float-registers)))
(inst call function)
;; To give the debugger a clue. XX not really internal-error?
(note-this-location vop :internal-error)
;; FLOAT15 needs to contain FP zero in Lispland
- (inst xor rcx rcx)
- (inst movd (make-random-tn :kind :normal
- :sc (sc-or-lose 'double-reg)
- :offset float15-offset)
- rcx)))
+ (let ((float15 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset float15-offset)))
+ (inst xorpd float15 float15))))
(define-vop (alloc-number-stack-space)
(:info amount)
(aver (location= result rsp-tn))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (inst sub rsp-tn delta)))
+ (inst sub rsp-tn delta)))
;; C stack must be 16 byte aligned
(inst and rsp-tn #xfffffff0)
(move result rsp-tn)))
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (inst add rsp-tn delta)))))
+ (inst add rsp-tn delta)))))
(define-vop (alloc-alien-stack-space)
(:info amount)
(aver (not (location= result rsp-tn)))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (inst mov temp
- (make-ea :dword
- :disp (+ nil-value
- (static-symbol-offset '*alien-stack*)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
- (inst fs-segment-prefix)
- (inst sub (make-ea :dword :scale 1 :index temp) delta)))
+ (inst mov temp
+ (make-ea :qword
+ :disp (+ nil-value
+ (static-symbol-offset '*alien-stack*)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
+ (inst sub (make-ea :qword :base thread-base-tn
+ :scale 1 :index temp) delta)))
(load-tl-symbol-value result *alien-stack*))
#!-sb-thread
(:generator 0
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 7) 7)))
- (inst mov temp
- (make-ea :dword
- :disp (+ nil-value
- (static-symbol-offset '*alien-stack*)
- (ash symbol-tls-index-slot word-shift)
- (- other-pointer-lowtag))))
- (inst fs-segment-prefix)
- (inst add (make-ea :dword :scale 1 :index temp) delta))))
+ (inst mov temp
+ (make-ea :qword
+ :disp (+ nil-value
+ (static-symbol-offset '*alien-stack*)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag))))
+ (inst add (make-ea :qword :base thread-base-tn :scale 1 :index temp)
+ delta))))
#!-sb-thread
(:generator 0
(unless (zerop amount)
projects / sbcl.git / blobdiff