X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmips%2Fc-call.lisp;h=5e0cf13da77ad75a0ec68d1fa186829101d19fc3;hb=52cfe54802db8736f1f4e2b67764c43bba9b78b3;hp=d020fcefc2709ff55f87e56ca273335edde3b8ef;hpb=449088454569070e400f9f562c247bdc17cf60b5;p=sbcl.git diff --git a/src/compiler/mips/c-call.lisp b/src/compiler/mips/c-call.lisp index d020fce..5e0cf13 100644 --- a/src/compiler/mips/c-call.lisp +++ b/src/compiler/mips/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 (stack-frame-size 0) @@ -26,13 +26,13 @@ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (setf (arg-state-did-int-arg state) t) (multiple-value-bind - (ptype reg-sc stack-sc) - (if (alien-integer-type-signed type) - (values 'signed-byte-32 'signed-reg 'signed-stack) - (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)) + (ptype reg-sc stack-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-32 'signed-reg 'signed-stack) + (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)) (if (< stack-frame-size 4) - (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4)) - (my-make-wired-tn ptype stack-sc stack-frame-size))))) + (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4)) + (my-make-wired-tn ptype stack-sc stack-frame-size))))) (define-alien-type-method (system-area-pointer :arg-tn) (type state) (declare (ignore type)) @@ -40,29 +40,29 @@ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (setf (arg-state-did-int-arg state) t) (if (< stack-frame-size 4) - (my-make-wired-tn 'system-area-pointer - 'sap-reg - (+ stack-frame-size 4)) - (my-make-wired-tn 'system-area-pointer - 'sap-stack - stack-frame-size)))) + (my-make-wired-tn 'system-area-pointer + 'sap-reg + (+ stack-frame-size 4)) + (my-make-wired-tn 'system-area-pointer + 'sap-stack + stack-frame-size)))) (define-alien-type-method (double-float :arg-tn) (type state) (declare (ignore type)) (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1)) - (float-args (arg-state-float-args state))) + (float-args (arg-state-float-args state))) (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2)) (setf (arg-state-float-args state) (1+ float-args)) (cond ((>= stack-frame-size 4) - (my-make-wired-tn 'double-float - 'double-stack - stack-frame-size)) - ((and (not (arg-state-did-int-arg state)) - (< float-args 2)) - (my-make-wired-tn 'double-float - 'double-reg - (+ (* float-args 2) 12))) - (t + (my-make-wired-tn 'double-float + 'double-stack + stack-frame-size)) + ((and (not (arg-state-did-int-arg state)) + (< float-args 2)) + (my-make-wired-tn 'double-float + 'double-reg + (+ (* float-args 2) 12))) + (t (my-make-wired-tn 'double-float 'double-int-carg-reg (+ stack-frame-size 4)))))) @@ -70,19 +70,19 @@ (define-alien-type-method (single-float :arg-tn) (type state) (declare (ignore type)) (let ((stack-frame-size (arg-state-stack-frame-size state)) - (float-args (arg-state-float-args state))) + (float-args (arg-state-float-args state))) (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (setf (arg-state-float-args state) (1+ float-args)) (cond ((>= stack-frame-size 4) - (my-make-wired-tn 'single-float - 'single-stack - stack-frame-size)) - ((and (not (arg-state-did-int-arg state)) - (< float-args 2)) - (my-make-wired-tn 'single-float - 'single-reg - (+ (* float-args 2) 12))) - (t + (my-make-wired-tn 'single-float + 'single-stack + stack-frame-size)) + ((and (not (arg-state-did-int-arg state)) + (< float-args 2)) + (my-make-wired-tn 'single-float + 'single-reg + (+ (* float-args 2) 12))) + (t (my-make-wired-tn 'single-float 'single-int-carg-reg (+ stack-frame-size 4)))))) @@ -99,9 +99,9 @@ (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) @@ -128,105 +128,105 @@ (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 nsp-offset) - (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes) - (arg-tns) - (invoke-alien-type-method :result-tn - (alien-fun-type-result-type type) - (make-result-state)))))) + (* (max (arg-state-stack-frame-size arg-state) 4) 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)) - (env (sb!kernel:make-null-lexenv)) - (arg-types (alien-fun-type-arg-types type)) - (result-type (alien-fun-type-result-type type))) + (env (sb!kernel:make-null-lexenv)) + (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 64-bit integer arguments ;; and results. (if (or (some #'(lambda (type) - (and (alien-integer-type-p type) - (> (sb!alien::alien-integer-type-bits type) 32))) - 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, endian word order, - ;; aligned to 8 bytes. - (if (oddp (length (new-args))) - (new-args nil)) - #!-little-endian - (progn (new-args `(ash ,arg -32)) - (new-args `(logand ,arg #xffffffff)) - (if (oddp (length (new-arg-types))) - (new-arg-types (parse-alien-type '(unsigned 32) env))) - (if (alien-integer-type-signed type) - (new-arg-types (parse-alien-type '(signed 32) env)) - (new-arg-types (parse-alien-type '(unsigned 32) env))) - (new-arg-types (parse-alien-type '(unsigned 32) env))) - #!+little-endian - (progn (new-args `(logand ,arg #xffffffff)) - (new-args `(ash ,arg -32)) - (if (oddp (length (new-arg-types))) - (new-arg-types (parse-alien-type '(unsigned 32) env))) - (new-arg-types (parse-alien-type '(unsigned 32) env)) - (if (alien-integer-type-signed type) - (new-arg-types (parse-alien-type '(signed 32) env)) - (new-arg-types (parse-alien-type '(unsigned 32) env))))) - (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) - #!-little-endian - '(values (signed 32) (unsigned 32)) - #!+little-endian - '(values (unsigned 32) (signed 32)) - '(values (unsigned 32) (unsigned 32))) - env)))) - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (multiple-value-bind - #!-little-endian - (high low) - #!+little-endian - (low high) - (%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)))) + (and (alien-integer-type-p type) + (> (sb!alien::alien-integer-type-bits type) 32))) + 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, endian word order, + ;; aligned to 8 bytes. + (if (oddp (length (new-args))) + (new-args nil)) + #!-little-endian + (progn (new-args `(ash ,arg -32)) + (new-args `(logand ,arg #xffffffff)) + (if (oddp (length (new-arg-types))) + (new-arg-types (parse-alien-type '(unsigned 32) env))) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32) env)) + (new-arg-types (parse-alien-type '(unsigned 32) env))) + (new-arg-types (parse-alien-type '(unsigned 32) env))) + #!+little-endian + (progn (new-args `(logand ,arg #xffffffff)) + (new-args `(ash ,arg -32)) + (if (oddp (length (new-arg-types))) + (new-arg-types (parse-alien-type '(unsigned 32) env))) + (new-arg-types (parse-alien-type '(unsigned 32) env)) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32) env)) + (new-arg-types (parse-alien-type '(unsigned 32) env))))) + (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) + #!-little-endian + '(values (signed 32) (unsigned 32)) + #!+little-endian + '(values (unsigned 32) (signed 32)) + '(values (unsigned 32) (unsigned 32))) + env)))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (multiple-value-bind + #!-little-endian + (high low) + #!+little-endian + (low high) + (%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)) @@ -238,23 +238,22 @@ (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 control-stack :offset nfp-save-offset) nfp-save) (:vop-var vop) (:generator 0 (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move cfunc function) + (store-stack-tn nfp-save cur-nfp)) (inst jal (make-fixup "call_into_c" :foreign)) - (inst nop) + (move cfunc function t) (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) @@ -263,11 +262,11 @@ (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst subu nsp-tn delta)) - (t - (inst li temp delta) - (inst subu nsp-tn temp))))) + (cond ((< delta (ash 1 15)) + (inst subu nsp-tn delta)) + (t + (inst li temp delta) + (inst subu nsp-tn temp))))) (move result nsp-tn))) (define-vop (dealloc-number-stack-space) @@ -277,8 +276,8 @@ (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst addu nsp-tn delta)) - (t - (inst li temp delta) - (inst addu nsp-tn temp))))))) + (cond ((< delta (ash 1 15)) + (inst addu nsp-tn delta)) + (t + (inst li temp delta) + (inst addu nsp-tn temp)))))))