X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fc-call.lisp;h=8cd0e0743e21aa0b30c2d27c3f714cb668db3309;hb=37d3828773e2f847bb1ed7522b0af4fb8e736fc8;hp=023c99b8c80c2db71a0f94224e2ba6b6369485b5;hpb=2216330b380c4a931ea7564e0b5a7d4bbec75851;p=sbcl.git diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 023c99b..8cd0e07 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) @@ -214,15 +262,24 @@ :from :eval :to :result) ecx) (:temporary (:sc unsigned-reg :offset edx-offset :from :eval :to :result) edx) - (:node-var node) + #!+sb-safepoint (:temporary (:sc unsigned-reg :offset esi-offset) esi) + #!+sb-safepoint (:temporary (:sc unsigned-reg :offset edi-offset) edi) + #!-sb-safepoint (:node-var node) (:vop-var vop) (:save-p t) - (:ignore args ecx edx) + (:ignore args ecx edx + #!+sb-safepoint esi + #!+sb-safepoint edi) (: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)) + (cond ((and + ;; On safepoints builds, we currently use the out-of-line + ;; calling routine irrespectively of SPACE and SPEED policy. + ;; An inline version of said changes is left to the + ;; sufficiently motivated maintainer. + #!-sb-safepoint (policy node (> space speed))) (move eax function) (inst call (make-fixup "call_into_c" :foreign))) (t @@ -279,6 +336,7 @@ (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) @@ -291,15 +349,16 @@ (: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-for-symbol-tls-index *alien-stack*)) - (inst fs-segment-prefix) - (inst sub (make-ea :dword :base temp) delta))) + (with-tls-ea (EA :base temp + :disp-type :index + :disp (make-ea-for-symbol-tls-index *alien-stack*)) + (inst sub EA delta :maybe-fs)))) (load-tl-symbol-value result *alien-stack*)) #!-sb-thread (:generator 0 @@ -317,10 +376,10 @@ (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst mov temp - (make-ea-for-symbol-tls-index *alien-stack*)) - (inst fs-segment-prefix) - (inst add (make-ea :dword :base temp) delta)))) + (with-tls-ea (EA :base temp + :disp-type :index + :disp (make-ea-for-symbol-tls-index *alien-stack*)) + (inst add EA delta :maybe-fs))))) #!-sb-thread (:generator 0 (unless (zerop amount) @@ -365,15 +424,23 @@ pointer to the arguments." (inst push eax) ; arg1 (inst push (ash index 2)) ; arg0 - ;; Indirect the access to ENTER-ALIEN-CALLBACK through - ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK* - ;; 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 - (load-symbol-value eax sb!alien::*enter-alien-callback*) - (inst push eax) ; function - (inst mov eax (foreign-symbol-address "funcall3")) - (inst call eax) + #!+sb-safepoint + (progn + (inst mov eax (foreign-symbol-address "callback_wrapper_trampoline")) + (inst call eax)) + + #!-sb-safepoint + (progn + ;; Indirect the access to ENTER-ALIEN-CALLBACK through + ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK* + ;; 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 + (load-symbol-value eax sb!alien::*enter-alien-callback*) + (inst push eax) ; function + (inst mov eax (foreign-symbol-address "funcall3")) + (inst call eax)) + ;; now put the result into the right register (cond ((and (alien-integer-type-p return-type)