diff --git a/compiler/rt/c-call.lisp b/compiler/rt/c-call.lisp index 7bd6edbe1901c5d51a50a06650e224dceefb0636..9d07ce891f59786c3f45db5dd60e99dccd15b4c9 100644 --- a/compiler/rt/c-call.lisp +++ b/compiler/rt/c-call.lisp @@ -7,7 +7,7 @@ ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/c-call.lisp,v 1.3 1991/04/21 19:52:56 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/c-call.lisp,v 1.4 1992/03/09 20:42:20 wlott Exp $ ;;; ;;; This file contains the VOPs and other necessary machine specific support ;;; routines for call-out to C. @@ -19,133 +19,163 @@ (in-package "RT") + +;;;; Make-call-out-argument-tns and support stuff. (defun c-call-wired-tn (primitive-type sc-name offset) (make-wired-tn (primitive-type-or-lose primitive-type) (sc-number-or-lose sc-name) offset)) -(def-vm-support-routine make-call-out-nsp-tn () - (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset)) - - -(def-vm-support-routine make-call-out-argument-tns (arg-types) - (let ((nargs 0)) - (collect ((tns)) - (dolist (type arg-types) - (multiple-value-bind - (ptype reg-sc stack-sc) - (ecase (if (consp type) (car type) type) - ((unsigned-byte port) - (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)) - (signed-byte - (values 'signed-byte-32 'signed-reg 'signed-stack)) - (system-area-pointer - (values 'system-area-pointer 'sap-reg 'sap-stack))) - ;; C expects 4 register args and the 5th arg at the top of the stack. - ;; We can't put args in registers, because we need those registers - ;; for something else. So we put them just beyond the end of the - ;; stack and the trampoline code will move them into place. - (tns (c-call-wired-tn ptype stack-sc nargs)) - (incf nargs))) - (values (tns) - (* nargs word-bytes))))) - -(def-vm-support-routine make-call-out-result-tn (type) - (let ((offset nl0-offset)) - (labels - ((frob (type) - (let ((name (if (consp type) (car type) type))) - (prog1 - (ecase name - ((unsigned-byte port) - (c-call-wired-tn 'unsigned-byte-32 'unsigned-reg offset)) - (signed-byte - (c-call-wired-tn 'signed-byte-32 'signed-reg offset)) - (system-area-pointer - (c-call-wired-tn 'system-area-pointer 'sap-reg offset)) - (values - (when (consp type) - (mapcar #'frob (cdr type))))) - (incf offset))))) - (frob type)))) - -(deftransform ext::call-foreign-function - ((name return-type arg-types &rest args) - (string * list &rest t)) - (assert (c::constant-continuation-p name)) - (assert (c::constant-continuation-p return-type)) - (assert (c::constant-continuation-p arg-types)) - (let ((name (c::continuation-value name)) - (return-type (c::continuation-value return-type)) - (arg-types (c::continuation-value arg-types))) + +(defstruct arg-state + (stack-frame-size 0)) + +(defun int-arg (state prim-type stack-sc) + ;; C expects 4 register args and the 5th arg at the top of the stack. + ;; We can't put args in registers, because we need those registers + ;; for something else. So we put them just beyond the end of the + ;; stack and the trampoline code will move them into place. + (let ((frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ frame-size)) + (c-call-wired-tn prim-type stack-sc frame-size))) + +(defun int-result (state prim-type reg-sc) + (let ((reg-num (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ reg-num)) + (c-call-wired-tn prim-type reg-sc reg-num))) + +(def-alien-type-method (integer :arg-tn) (type state) + (if (alien-integer-type-signed type) + (int-arg state 'signed-byte-32 'signed-stack) + (int-arg state 'unsigned-byte-32 'unsigned-stack))) + +(def-alien-type-method (integer :result-tn) (type state) + (if (alien-integer-type-signed type) + (int-result state 'signed-byte-32 'signed-reg) + (int-result state 'unsigned-byte-32 'unsigned-reg))) + +(def-alien-type-method (alien::sap :arg-tn) (type state) + (declare (ignore type)) + (int-arg state 'system-area-pointer 'sap-stack)) + +(def-alien-type-method (alien::sap :result-tn) (type state) + (declare (ignore type)) + (int-result state 'system-area-pointer 'sap-reg)) + +(def-alien-type-method (values :result-tn) (type state) + (mapcar #'(lambda (type) + (invoke-alien-type-method :result-tn type state)) + (alien-values-type-values type))) + +(def-vm-support-routine make-call-out-argument-tns (type) + (declare (type alien-function-type type)) + (let ((arg-state (make-arg-state))) + (collect ((arg-tns)) + (dolist (arg-type (alien-function-type-arg-types type)) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (values (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset) + (* (arg-state-stack-frame-size arg-state) word-bytes) + (arg-tns) + (invoke-alien-type-method + :result-tn + (alien-function-type-result-type type) + (make-arg-state :frame-size nl0-offset)))))) + + +;;;; Deftransforms to convert uses of %alien-funcall into cononical form. + +(deftransform %alien-funcall ((function type &rest args) + (t * &rest t)) + (assert (c::constant-continuation-p type)) + (let* ((type (c::continuation-value type)) + (arg-types (alien-function-type-arg-types type)) + (result-type (alien-function-type-result-type type))) (assert (= (length arg-types) (length args))) - (if (member 'double-float arg-types) - (let ((new-args nil) - (lambda-vars nil) - (new-types nil)) + (if (some #'alien::alien-double-float-type-p arg-types) + (collect ((new-args) (lambda-vars) (new-arg-types)) (dolist (type arg-types) (let ((arg (gensym))) - (push arg lambda-vars) - (case type - (double-float - (push `(double-float-high-bits ,arg) new-args) - (push '(signed-byte 32) new-types) - (push `(double-float-low-bits ,arg) new-args) - (push '(unsigned-byte 32) new-types)) + (lambda-vars arg) + (typecase type + (alien::alien-double-float-type + (new-args `(double-float-high-bits ,arg)) + (new-args `(double-float-low-bits ,arg)) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32)))) (t - (push arg new-args) - (push type new-types))))) - `(lambda (name return-type arg-types ,@(nreverse lambda-vars)) - (declare (ignore name return-type arg-types)) - (ext::call-foreign-function ,name ',return-type - ',(nreverse new-types) - ,@(nreverse new-args)))) + (new-args arg) + (new-arg-types type))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(alien::make-alien-function-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args)))) (c::give-up)))) -(deftransform ext::call-foreign-function - ((name return-type arg-types &rest args) - (string t * &rest t)) - (assert (c::constant-continuation-p name)) - (assert (c::constant-continuation-p return-type)) - (assert (c::constant-continuation-p arg-types)) - (let ((name (c::continuation-value name)) - (return-type (c::continuation-value return-type)) - (arg-types (c::continuation-value arg-types)) - (arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args))) - (case return-type - (double-float - `(lambda (name return-type arg-types ,@arg-names) - (declare (ignore name return-type arg-types)) - (multiple-value-bind - (hi lo) - (ext::call-foreign-function ,name - '(values signed-byte unsigned-byte) - ',arg-types - ,@arg-names) - (make-double-float hi lo)))) - (single-float - `(lambda (name return-type arg-types ,@arg-names) - (make-single-float - (ext::call-foreign-function ,name 'signed-byte ',arg-types - ,@arg-names)))) - (t - (c::give-up))))) +(deftransform %alien-funcall ((function type &rest args) + (* t &rest t)) + (assert (c::constant-continuation-p type)) + (let* ((type (c::continuation-value type)) + (arg-types (alien-function-type-arg-types type)) + (result-type (alien-function-type-result-type type))) + (assert (= (length arg-types) (length args))) + (flet ((make-arg-name-list () + (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) + arg-types))) + (typecase result-type + (alien::alien-double-float-type + (let ((arg-names (make-arg-name-list))) + `(lambda (function type ,@arg-names) + (declare (ignore type)) + (multiple-value-bind + (hi lo) + (%alien-funcall function + ',(parse-alien-type + `(function (values (signed 32) + (unsigned 32)) + ,@arg-types)) + ,@arg-names) + (make-double-float hi lo))))) + (alien::alien-single-float-type + (let ((arg-names (make-arg-name-list))) + `(lambda (function type ,@arg-names) + (declare (ignore type)) + (make-single-float + (%alien-function function + ',(parse-alien-type + `(function (signed 32) ,@arg-types)) + ,@arg-names))))) + (t + (c::give-up)))))) + + +;;;; Vops. + (define-vop (foreign-symbol-address) + (:translate foreign-symbol-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) (:info foreign-symbol) (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) (:generator 2 (inst cai res (make-fixup (concatenate 'simple-string "_" foreign-symbol) :foreign)))) (define-vop (call-out) - (:args (args :more t)) + (:args (function :scs (sap-reg) :target nl0) + (args :more t)) (:results (results :more t)) (:ignore args results) (:save-p t) (:info function) - (:temporary (:sc any-reg :offset nl0-offset :to (:result 0)) nl0) + (:temporary (:sc any-reg :offset nl0-offset + :from (:argument 0) :to (:result 0)) nl0) (:temporary (:sc any-reg :offset lra-offset) lra) (:temporary (:sc any-reg :offset code-offset) code) (:temporary (:scs (sap-reg) :to (:result 0)) temp) @@ -154,11 +184,10 @@ (:generator 0 (let ((lra-label (gen-label)) (cur-nfp (current-nfp-tn vop))) + (move nl0 function) (when cur-nfp (store-stack-tn cur-nfp nfp-save)) (inst compute-lra-from-code lra code lra-label) - (inst cai nl0 - (make-fixup (concatenate 'simple-string "_" function) :foreign)) (inst cai temp (make-fixup "call_into_c" :foreign)) (inst b temp)