X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsparc%2Fc-call.lisp;h=1d9cb53e0b8aa927955b7a35c7887add02a325a3;hb=HEAD;hp=5932c661b58ab82baa3c053a30be33493877e8c9;hpb=6365d636fa30ff3e2c2ebc9668f978fa0ebc7a0e;p=sbcl.git diff --git a/src/compiler/sparc/c-call.lisp b/src/compiler/sparc/c-call.lisp index 5932c66..1d9cb53 100644 --- a/src/compiler/sparc/c-call.lisp +++ b/src/compiler/sparc/c-call.lisp @@ -13,8 +13,8 @@ (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) @@ -26,12 +26,12 @@ (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) @@ -54,17 +54,17 @@ (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)) @@ -84,107 +84,107 @@ (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) +(defun 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-address) - (:translate foreign-symbol-address) +(define-vop (foreign-symbol-sap) + (:translate foreign-symbol-sap) (:policy :fast-safe) (:args) (:arg-types (:constant simple-string)) @@ -195,8 +195,8 @@ (inst li 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)) @@ -210,12 +210,12 @@ (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) @@ -223,27 +223,28 @@ (: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) (:info amount) (:results (result :scs (sap-reg any-reg))) + (:result-types system-area-pointer) (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) (: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 @@ -257,8 +258,8 @@ (: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)))))))