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