X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmips%2Fc-call.lisp;h=5e0cf13da77ad75a0ec68d1fa186829101d19fc3;hb=52cfe54802db8736f1f4e2b67764c43bba9b78b3;hp=af0d2f8274374f0aea26d1087dca9aab4324a2ab;hpb=4ae1b794a5d6a90794468cf8017f5307f2c30dfe;p=sbcl.git diff --git a/src/compiler/mips/c-call.lisp b/src/compiler/mips/c-call.lisp index af0d2f8..5e0cf13 100644 --- a/src/compiler/mips/c-call.lisp +++ b/src/compiler/mips/c-call.lisp @@ -1,9 +1,20 @@ +;;;; VOPs and other machine-specific support routines for call-out to C + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + (in-package "SB!VM") (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) @@ -15,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)) @@ -29,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)))))) @@ -59,49 +70,45 @@ (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)))))) - (defstruct result-state (num-results 0)) -(defun offset-for-result (n) - (+ n 2) - #+nil - (if (= n 0) - cfunc-offset - (+ n 2))) +(defun result-reg-offset (slot) + (ecase slot + (0 nl0-offset) + (1 nl1-offset))) (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)) - (multiple-value-bind - (ptype reg-sc) - (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 (offset-for-result 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)) + (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 (offset-for-result num-results)))) + (my-make-wired-tn 'system-area-pointer 'sap-reg (result-reg-offset num-results)))) ;;; FIXME: do these still work? -- CSR, 2002-08-28 (define-alien-type-method (double-float :result-tn) (type state) @@ -117,25 +124,109 @@ (my-make-wired-tn 'single-float 'single-reg (* num-results 2)))) (define-alien-type-method (values :result-tn) (type state) - (mapcar #'(lambda (type) - (invoke-alien-type-method :result-tn type state)) - (alien-values-type-values type))) + (let ((values (alien-values-type-values type))) + (when (> (length values) 2) + (error "Too many result values from c-call.")) + (mapcar #'(lambda (type) + (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))) + (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)))) -(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)) @@ -147,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) @@ -172,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) @@ -186,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)))))))