offset))
(defstruct (arg-state (:copier nil))
+ (register-args 0)
+ (xmm-args 0)
(stack-frame-size 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))))))
+
(define-alien-type-method (integer :arg-tn) (type state)
- (let ((stack-frame-size (arg-state-stack-frame-size state)))
- (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
- (multiple-value-bind (ptype stack-sc)
- (if (alien-integer-type-signed type)
- (values 'signed-byte-64 'signed-stack)
- (values 'unsigned-byte-64 'unsigned-stack))
- (my-make-wired-tn ptype stack-sc stack-frame-size))))
+ (if (alien-integer-type-signed type)
+ (int-arg state 'signed-byte-64 'signed-reg 'signed-stack)
+ (int-arg state 'unsigned-byte-64 'unsigned-reg 'unsigned-stack)))
(define-alien-type-method (system-area-pointer :arg-tn) (type state)
(declare (ignore type))
- (let ((stack-frame-size (arg-state-stack-frame-size state)))
- (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
- (my-make-wired-tn 'system-area-pointer
- 'sap-stack
- stack-frame-size)))
-
-#!+long-float
-(define-alien-type-method (long-float :arg-tn) (type state)
- (declare (ignore type))
- (let ((stack-frame-size (arg-state-stack-frame-size state)))
- (setf (arg-state-stack-frame-size state) (+ stack-frame-size 3))
- (my-make-wired-tn 'long-float 'long-stack stack-frame-size)))
+ (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
+
+(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))))))
(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
- (let ((stack-frame-size (arg-state-stack-frame-size state)))
- (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
- (my-make-wired-tn 'double-float 'double-stack stack-frame-size)))
+ (float-arg state 'double-float 'double-reg 'double-stack))
(define-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
- (let ((stack-frame-size (arg-state-stack-frame-size state)))
- (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
- (my-make-wired-tn 'single-float 'single-stack stack-frame-size)))
+ (float-arg state 'single-float 'single-reg 'single-stack))
(defstruct (result-state (:copier nil))
(num-results 0))
(0 eax-offset)
(1 edx-offset)))
+;; XXX The return handling probably doesn't conform to the ABI
+
(define-alien-type-method (integer :result-tn) (type state)
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(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))
+ `(sign-extend ,alien)
+ alien))
+
(define-alien-type-method (system-area-pointer :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(my-make-wired-tn 'system-area-pointer 'sap-reg
(result-reg-offset num-results))))
-#!+long-float
-(define-alien-type-method (long-float :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 'long-float 'long-reg (* num-results 2))))
-
(define-alien-type-method (double-float :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 'double-float 'double-reg (* num-results 2))))
+ (my-make-wired-tn 'double-float 'double-reg num-results)))
(define-alien-type-method (single-float :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 'single-float 'single-reg (* num-results 2))))
+ (my-make-wired-tn 'single-float 'single-reg num-results)))
(define-alien-type-method (values :result-tn) (type state)
(let ((values (alien-values-type-values type)))
,@(new-args))))))
(sb!c::give-up-ir1-transform))))
+;;; 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))
-
+(define-vop (sign-extend)
+ (:translate sign-extend)
+ (:policy :fast-safe)
+ (:args (val :scs (any-reg)))
+ (:arg-types fixnum)
+ (:results (res :scs (any-reg)))
+ (:result-types fixnum)
+ (:generator 1
+ (inst movsxd res
+ (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)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-base-string))
+ (:arg-types (:constant simple-string))
+ (:info foreign-symbol)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 2
+ (inst lea res (make-fixup foreign-symbol :foreign))))
+
+#!+linkage-table
+(define-vop (foreign-symbol-dataref-address)
+ (:translate foreign-symbol-dataref-address)
+ (:policy :fast-safe)
+ (:args)
+ (:arg-types (:constant simple-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
- (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
+ (inst mov res (make-fixup foreign-symbol :foreign-dataref))))
(define-vop (call-out)
(:args (function :scs (sap-reg))
(args :more t))
(:results (results :more t))
- (:temporary (:sc unsigned-reg :offset eax-offset
- :from :eval :to :result) eax)
- (:temporary (:sc unsigned-reg :offset ecx-offset
- :from :eval :to :result) ecx)
- (:temporary (:sc unsigned-reg :offset edx-offset
- :from :eval :to :result) edx)
- (:node-var node)
+ (:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax)
+ (:ignore results)
(:vop-var vop)
(:save-p t)
- (:ignore args ecx edx)
(:generator 0
- (cond ((policy node (> space speed))
- (move eax function)
- (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)))
- (t
- ;; Setup the NPX for C; all the FP registers need to be
- ;; empty; pop them all.
- (dotimes (i 8)
- (inst fstp fr0-tn))
-
- (inst call function)
- ;; To give the debugger a clue. XX not really internal-error?
- (note-this-location vop :internal-error)
-
- ;; Restore the NPX for lisp; ensure no regs are empty
- (dotimes (i 7)
- (inst fldz))
-
- (if (and results
- (location= (tn-ref-tn results) fr0-tn))
- ;; The return result is in fr0.
- (inst fxch fr7-tn) ; move the result back to fr0
- (inst fldz)) ; insure no regs are empty
- ))))
+ ;; 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)))
+ (inst call function)
+ ;; To give the debugger a clue. XX not really internal-error?
+ (note-this-location vop :internal-error)
+ ;; FLOAT15 needs to contain FP zero in Lispland
+ (let ((float15 (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset float15-offset)))
+ (inst xorpd float15 float15))))
(define-vop (alloc-number-stack-space)
(:info amount)
(:generator 0
(aver (location= result rsp-tn))
(unless (zerop amount)
- (let ((delta (logandc2 (+ amount 3) 3)))
+ (let ((delta (logandc2 (+ amount 7) 7)))
(inst sub rsp-tn delta)))
+ ;; C stack must be 16 byte aligned
+ (inst and rsp-tn #xfffffff0)
(move result rsp-tn)))
(define-vop (dealloc-number-stack-space)
(:info amount)
(:generator 0
(unless (zerop amount)
- (let ((delta (logandc2 (+ amount 3) 3)))
+ (let ((delta (logandc2 (+ amount 7) 7)))
(inst add rsp-tn delta)))))
(define-vop (alloc-alien-stack-space)
(:generator 0
(aver (not (location= result rsp-tn)))
(unless (zerop amount)
- (let ((delta (logandc2 (+ amount 3) 3)))
+ (let ((delta (logandc2 (+ amount 7) 7)))
(inst mov temp
(make-ea :dword
:disp (+ nil-value
(:generator 0
(aver (not (location= result rsp-tn)))
(unless (zerop amount)
- (let ((delta (logandc2 (+ amount 3) 3)))
+ (let ((delta (logandc2 (+ amount 7) 7)))
(inst sub (make-ea :qword
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)
#!+sb-thread
(:generator 0
(unless (zerop amount)
- (let ((delta (logandc2 (+ amount 3) 3)))
+ (let ((delta (logandc2 (+ amount 7) 7)))
(inst mov temp
(make-ea :dword
:disp (+ nil-value
#!-sb-thread
(:generator 0
(unless (zerop amount)
- (let ((delta (logandc2 (+ amount 3) 3)))
+ (let ((delta (logandc2 (+ amount 7) 7)))
(inst add (make-ea :qword
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)