X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fc-call.lisp;h=7eec4723a4838d0ed621ff8c3e5e9f552c570bd2;hb=08917ec0d00a781a1089922a5419b7f136cdf08f;hp=c52ce27943f9da43b71be8d623d94be7896bd017;hpb=3d2165e67f9ad1443f6e7d8ad24810000b0436e8;p=sbcl.git diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index c52ce27..7eec472 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -78,6 +78,13 @@ (values 'unsigned-byte-32 'unsigned-reg)) (my-make-wired-tn ptype reg-sc (result-reg-offset num-results))))) +(define-alien-type-method (integer :naturalize-gen) (type alien) + (if (<= (alien-type-bits type) 16) + (if (alien-integer-type-signed type) + `(sign-extend ,alien ,(alien-type-bits type)) + `(logand ,alien ,(1- (ash 1 (alien-type-bits type))))) + alien)) + (define-alien-type-method (system-area-pointer :result-tn) (type state) (declare (ignore type)) (let ((num-results (result-state-num-results state))) @@ -181,6 +188,47 @@ ,@(new-args)))))) (sb!c::give-up-ir1-transform)))) +;;; The ABI is vague about how signed sub-word integer return values +;;; are handled, but since gcc versions >=4.3 no longer do sign +;;; extension in the callee, we need to do it in the caller. FIXME: +;;; If the value to be extended is known to already be of the target +;;; type at compile time, we can (and should) elide the extension. +(defknown sign-extend ((signed-byte 32) t) fixnum + (foldable flushable movable)) + +(define-vop (sign-extend) + (:translate sign-extend) + (:policy :fast-safe) + ;; Need to wire this to EAX since in x86 some dword registers don't + ;; have a matching word or byte register. + (:args (val :scs (signed-reg) :target eax)) + (:temporary (:sc signed-reg :offset eax-offset :from :eval :to :result) eax) + (:arg-types signed-num (:constant fixnum)) + (:info size) + (:results (res :scs (signed-reg))) + (:result-types fixnum) + (:ignore eax) + (:generator 1 + (inst movsx res + (make-random-tn :kind :normal + :sc (sc-or-lose (ecase size + (8 'byte-reg) + (16 'word-reg))) + :offset (tn-offset val))))) + +#-sb-xc-host +(defun sign-extend (x size) + (declare (type (signed-byte 32) x)) + (ecase size + (8 (sign-extend x size)) + (16 (sign-extend x size)))) + +#+sb-xc-host +(defun sign-extend (x size) + (if (logbitp (1- size) x) + (dpb x (byte size 0) -1) + x)) + (define-vop (foreign-symbol-sap) (:translate foreign-symbol-sap) (:policy :fast-safe) @@ -219,6 +267,9 @@ (:save-p t) (:ignore args ecx edx) (:generator 0 + ;; FIXME & OAOOM: This is brittle and error-prone to maintain two + ;; instances of the same logic, on in arch-assem.S, and one in + ;; c-call.lisp. If you modify this, modify that one too... (cond ((policy node (> space speed)) (move eax function) (inst call (make-fixup "call_into_c" :foreign))) @@ -228,10 +279,12 @@ (dotimes (i 8) (inst fstp fr0-tn)) - #!+win32 (inst cld) + ;; Clear out DF: Darwin, Windows, and Solaris at least require + ;; this, and it should not hurt others either. + (inst cld) (inst call function) - ;; To give the debugger a clue. XX not really internal-error? + ;; To give the debugger a clue. FIXME: not really internal-error? (note-this-location vop :internal-error) ;; Restore the NPX for lisp; ensure no regs are empty @@ -241,8 +294,8 @@ (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 + (inst fxch fr7-tn) ; move the result back to fr0 + (inst fldz)) ; insure no regs are empty )))) ;;; While SBCL uses the FPU in 53-bit mode, most C libraries assume that @@ -274,50 +327,35 @@ (define-vop (alloc-number-stack-space) (:info amount) (:results (result :scs (sap-reg any-reg))) + (:result-types system-area-pointer) (:generator 0 (aver (location= result esp-tn)) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) (inst sub esp-tn delta))) - ;; C stack should probably be 16 byte aligned on Darwin - #!+darwin (inst and esp-tn -16) + (align-stack-pointer esp-tn) (move result esp-tn))) -(define-vop (dealloc-number-stack-space) - (:info amount) - (:generator 0 - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 3) 3))) - (inst add esp-tn delta))))) - (define-vop (alloc-alien-stack-space) (:info amount) #!+sb-thread (:temporary (:sc unsigned-reg) temp) (:results (result :scs (sap-reg any-reg))) + (:result-types system-area-pointer) #!+sb-thread (:generator 0 (aver (not (location= result esp-tn))) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) (inst mov temp - (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-tls-index-slot word-shift) - (- other-pointer-lowtag)))) - (inst fs-segment-prefix) - (inst sub (make-ea :dword :scale 1 :index temp) delta))) + (make-ea-for-symbol-tls-index *alien-stack*)) + (inst sub (make-ea :dword :base temp) delta :fs))) (load-tl-symbol-value result *alien-stack*)) #!-sb-thread (:generator 0 (aver (not (location= result esp-tn))) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst sub (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) + (inst sub (make-ea-for-symbol-value *alien-stack*) delta))) (load-symbol-value result *alien-stack*))) @@ -329,45 +367,25 @@ (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) (inst mov temp - (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-tls-index-slot word-shift) - (- other-pointer-lowtag)))) - (inst fs-segment-prefix) - (inst add (make-ea :dword :scale 1 :index temp) delta)))) + (make-ea-for-symbol-tls-index *alien-stack*)) + (inst add (make-ea :dword :base temp) delta :fs)))) #!-sb-thread (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst add (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) + (inst add (make-ea-for-symbol-value *alien-stack*) delta))))) -;;; these are not strictly part of the c-call convention, but are -;;; needed for the WITH-PRESERVED-POINTERS macro used for "locking -;;; down" lisp objects so that GC won't move them while foreign -;;; functions go to work. - -(define-vop (push-word-on-c-stack) - (:translate push-word-on-c-stack) - (:args (val :scs (sap-reg))) +;;; not strictly part of the c-call convention, but needed for the +;;; WITH-PINNED-OBJECTS macro used for "locking down" lisp objects so +;;; that GC won't move them while foreign functions go to work. +(define-vop (touch-object) + (:translate touch-object) + (:args (object)) + (:ignore object) (:policy :fast-safe) - (:arg-types system-area-pointer) - (:generator 2 - (inst push val))) - -(define-vop (pop-words-from-c-stack) - (:translate pop-words-from-c-stack) - (:args) - (:arg-types (:constant (unsigned-byte 29))) - (:info number) - (:policy :fast-safe) - (:generator 2 - (inst add esp-tn (fixnumize number)))) + (:arg-types t) + (:generator 0)) #-sb-xc-host (defun alien-callback-accessor-form (type sp offset) @@ -400,9 +418,7 @@ pointer to the arguments." ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK. ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone ;; to rebind the variable. -- JES, 2006-01-01 - (inst mov eax (+ nil-value (static-symbol-offset - 'sb!alien::*enter-alien-callback*))) - (loadw eax eax symbol-value-slot other-pointer-lowtag) + (load-symbol-value eax sb!alien::*enter-alien-callback*) (inst push eax) ; function (inst mov eax (foreign-symbol-address "funcall3")) (inst call eax)