From 2840e828d5435a3c04260ab22cb046917847ce21 Mon Sep 17 00:00:00 2001 From: toy <toy> Date: Wed, 2 Jul 2003 21:48:23 +0000 Subject: [PATCH] Use DOUBLE-FLOAT-BITS to get the bits of the double-float in the right way for alien calls. Saves 1 store to memory for each double-float arg. --- compiler/sparc/c-call.lisp | 151 ++++++++++++++++++++++--------------- 1 file changed, 89 insertions(+), 62 deletions(-) diff --git a/compiler/sparc/c-call.lisp b/compiler/sparc/c-call.lisp index 48364e75b..177903a5f 100644 --- a/compiler/sparc/c-call.lisp +++ b/compiler/sparc/c-call.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.20 2003/05/16 12:20:58 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.21 2003/07/02 21:48:23 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -126,67 +126,94 @@ #+long-float (some #'alien-long-float-type-p arg-types) (and (alien-integer-type-p result-type) (> (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) - (> (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))) - (new-arg-types (parse-alien-type '(unsigned 32)))) - (new-arg-types (parse-alien-type '(unsigned 32)))) - ((alien-single-float-type-p type) - (new-args `(single-float-bits ,arg)) - (new-arg-types (parse-alien-type '(signed 32)))) - ((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))) - (new-arg-types (parse-alien-type '(unsigned 32)))) - #+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))) - (new-arg-types (parse-alien-type '(unsigned 32))) - (new-arg-types (parse-alien-type '(unsigned 32))) - (new-arg-types (parse-alien-type '(unsigned 32)))) - (t - (new-args arg) - (new-arg-types type))))) - (cond ((and (alien-integer-type-p result-type) - (> (alien::alien-integer-type-bits result-type) 32)) - (let ((new-result-type - (let ((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))))))) - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (multiple-value-bind (high low) - (%alien-funcall function - ',(make-alien-function-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-function-type - :arg-types (new-arg-types) - :result-type result-type) - ,@(new-args)))))) + (collect ((new-args) (lambda-vars) (new-arg-types) (mv-vars) (mv-form)) + (dolist (type arg-types) + (let ((arg (gensym))) + (lambda-vars arg) + (cond ((and (alien-integer-type-p type) + (> (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))) + (new-arg-types (parse-alien-type '(unsigned 32)))) + (new-arg-types (parse-alien-type '(unsigned 32)))) + ((alien-single-float-type-p type) + (new-args `(single-float-bits ,arg)) + (new-arg-types (parse-alien-type '(signed 32)))) + ((alien-double-float-type-p type) + ;; Use double-float-bits instead of + ;; double-float-hi/lo-bits to get the bits + ;; out. This gives a some improvement + ;; because there's only store of the FP value. + ;; + ;; Sparc calling conventions say floats must be + ;; passed in the integer registers. + (let ((mvarg1 (gensym)) + (mvarg2 (gensym))) + (mv-vars `(,mvarg1 ,mvarg2)) + (mv-form `(double-float-bits ,arg)) + (new-args mvarg1) + (new-args mvarg2) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32))))) + #+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))) + (new-arg-types (parse-alien-type '(unsigned 32))) + (new-arg-types (parse-alien-type '(unsigned 32))) + (new-arg-types (parse-alien-type '(unsigned 32)))) + (t + (new-args arg) + (new-arg-types type))))) + (flet ((mv (vars forms body) + ;; Create the set of nested mv-binds + (let ((res body)) + (do ((v (reverse vars) (cdr v)) + (f (reverse forms) (cdr f))) + ((null v)) + (setf res `(multiple-value-bind ,(car v) + ,(car f) + ,res))) + res))) + (cond ((and (alien-integer-type-p result-type) + (> (alien::alien-integer-type-bits result-type) 32)) + (let* ((new-result-type + (let ((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)))))) + (body (mv (mv-vars) + (mv-form) + `(multiple-value-bind (high low) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args)) + (logior low (ash high 32)))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + ,body))) + (t + (let ((body (mv (mv-vars) + (mv-form) + `(%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + ,body)))))) (c::give-up)))) -- GitLab