From c441f5e334512cf44e5892abd1354d9e2ca634dc Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Tue, 25 Feb 1992 07:02:54 +0000 Subject: [PATCH] New alien changes. --- compiler/sparc/c-call.lisp | 168 +++++++++++++++++++------------------ 1 file changed, 87 insertions(+), 81 deletions(-) diff --git a/compiler/sparc/c-call.lisp b/compiler/sparc/c-call.lisp index e4bb888f9..6f52a1052 100644 --- a/compiler/sparc/c-call.lisp +++ b/compiler/sparc/c-call.lisp @@ -2,12 +2,14 @@ ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public -;;; domain. If you want to use this code or any part of CMU Common -;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) -;;; ********************************************************************** +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.3 1992/02/25 07:02:54 wlott Exp $") ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/c-call.lisp,v 1.2 1991/04/21 16:58:26 wlott Exp $ +;;; ********************************************************************** ;;; ;;; This file contains the VOPs and other necessary machine specific support ;;; routines for call-out to C. @@ -15,107 +17,112 @@ ;;; Written by William Lott. ;;; (in-package "SPARC") +(use-package "ALIEN") +(use-package "ALIEN-INTERNALS") (defun my-make-wired-tn (prim-type-name sc-name offset) (make-wired-tn (primitive-type-or-lose prim-type-name *backend*) (sc-number-or-lose sc-name *backend*) offset)) -(def-vm-support-routine make-call-out-nsp-tn () - (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)) +(defstruct arg-state + (register-args 0) + (stack-frame-size 0)) + +(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 1 6))))))) -(def-vm-support-routine make-call-out-argument-tns (arg-types) - (let ((register-args 0) - (stack-frame-size 0)) - (collect ((tns)) - (dolist (type arg-types) - (let ((name (if (consp type) (car type) type))) - (flet ((int-arg (prim-type sc) - (cond ((< register-args 6) - (tns (my-make-wired-tn prim-type sc - (+ register-args nl0-offset))) - (incf register-args)) - (t - (tns (my-make-wired-tn prim-type sc - (+ stack-frame-size 16 1 6))) - (incf stack-frame-size))))) - (ecase name - ((unsigned-byte port) - (int-arg 'unsigned-byte-32 'unsigned-reg)) - (signed-byte - (int-arg 'signed-byte-32 'signed-reg)) - (system-area-pointer - (int-arg 'system-area-pointer 'sap-reg)) - (double-float - (error "A double-float made it through the deftransform?")) - (single-float - (error "Can't deal with floats yet.")))))) - (values (tns) - (* stack-frame-size word-bytes))))) +(def-alien-type-method (integer :arg-tn) (type state) + (if (alien-integer-type-signed type) + (int-arg state 'signed-byte-32 'signed-reg 'signed-stack) + (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))) -(def-vm-support-routine make-call-out-result-tn (type) - (let ((name (if (consp type) (car type) type))) - (ecase name - ((unsigned-byte port) - (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)) - (signed-byte - (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)) - (system-area-pointer - (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset)) - (double-float - (my-make-wired-tn 'double-float 'double-reg 0)) - (single-float - (error "Can't return single-floats yet."))))) +(def-alien-type-method (alien::sap :arg-tn) (type state) + (declare (ignore type)) + (int-arg state 'system-area-pointer 'sap-reg 'sap-stack)) +(def-alien-type-method (integer :result-tn) (type) + (if (alien-integer-type-signed type) + (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset) + (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset))) + +(def-alien-type-method (alien::sap :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset)) -(deftransform ext::call-foreign-function - ((name return-type arg-types &rest args) - (string t 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))) +(def-alien-type-method (double-float :result-tn) (type) + (declare (ignore type)) + (my-make-wired-tn 'double-float 'double-reg 0)) + +(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 (my-make-wired-tn 'positive-fixnum 'any-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)))))) + +(deftransform %alien-funcall ((function type &rest args)) + (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)) - (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)))) + (lambda-vars arg) + (cond ((alien::alien-double-float-type-p type) + (new-args `(double-float-low-bits ,arg)) + (new-args `(double-float-high-bits ,arg)) + (new-arg-types (parse-alien-type '(unsigned 32))) + (new-arg-types (parse-alien-type '(signed 32)))) + (t + (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)))) (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 li res (make-fixup (concatenate 'simple-string "_" foreign-symbol) :foreign)))) (define-vop (call-out) - (:args (args :more t)) + (:args (function :scs (sap-reg) :target cfunc) + (args :more t)) (:results (results :more t)) (:ignore args results) (:save-p t) - (:info function) - (:temporary (:sc any-reg :offset cfunc-offset :to (:result 0)) cfunc) + (:temporary (:sc any-reg :offset cfunc-offset + :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) @@ -124,8 +131,7 @@ (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) - (inst li cfunc - (make-fixup (concatenate 'simple-string "_" function) :foreign)) + (move cfunc function) (inst li temp (make-fixup "_call_into_c" :foreign)) (inst jal lip temp) (inst nop) -- GitLab