Skip to content
Snippets Groups Projects
Commit c441f5e3 authored by wlott's avatar wlott
Browse files

New alien changes.

parent 17397d2a
No related branches found
No related tags found
No related merge requests found
...@@ -2,12 +2,14 @@ ...@@ -2,12 +2,14 @@
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at ;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; domain. If you want to use this code or any part of CMU Common ;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) ;;; 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 ;;; This file contains the VOPs and other necessary machine specific support
;;; routines for call-out to C. ;;; routines for call-out to C.
...@@ -15,107 +17,112 @@ ...@@ -15,107 +17,112 @@
;;; Written by William Lott. ;;; Written by William Lott.
;;; ;;;
(in-package "SPARC") (in-package "SPARC")
(use-package "ALIEN")
(use-package "ALIEN-INTERNALS")
(defun my-make-wired-tn (prim-type-name sc-name offset) (defun my-make-wired-tn (prim-type-name sc-name offset)
(make-wired-tn (primitive-type-or-lose prim-type-name *backend*) (make-wired-tn (primitive-type-or-lose prim-type-name *backend*)
(sc-number-or-lose sc-name *backend*) (sc-number-or-lose sc-name *backend*)
offset)) offset))
(def-vm-support-routine make-call-out-nsp-tn () (defstruct arg-state
(my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)) (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) (def-alien-type-method (integer :arg-tn) (type state)
(let ((register-args 0) (if (alien-integer-type-signed type)
(stack-frame-size 0)) (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
(collect ((tns)) (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
(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-vm-support-routine make-call-out-result-tn (type) (def-alien-type-method (alien::sap :arg-tn) (type state)
(let ((name (if (consp type) (car type) type))) (declare (ignore type))
(ecase name (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
((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 (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 (def-alien-type-method (double-float :result-tn) (type)
((name return-type arg-types &rest args) (declare (ignore type))
(string t list &rest t)) (my-make-wired-tn 'double-float 'double-reg 0))
(assert (c::constant-continuation-p name))
(assert (c::constant-continuation-p return-type)) (def-vm-support-routine make-call-out-argument-tns (type)
(assert (c::constant-continuation-p arg-types)) (declare (type alien-function-type type))
(let ((name (c::continuation-value name)) (let ((arg-state (make-arg-state)))
(return-type (c::continuation-value return-type)) (collect ((arg-tns))
(arg-types (c::continuation-value arg-types))) (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))) (assert (= (length arg-types) (length args)))
(if (member 'double-float arg-types) (if (some #'alien::alien-double-float-type-p arg-types)
(let ((new-args nil) (collect ((new-args) (lambda-vars) (new-arg-types))
(lambda-vars nil)
(new-types nil))
(dolist (type arg-types) (dolist (type arg-types)
(let ((arg (gensym))) (let ((arg (gensym)))
(push arg lambda-vars) (lambda-vars arg)
(case type (cond ((alien::alien-double-float-type-p type)
(double-float (new-args `(double-float-low-bits ,arg))
(push `(double-float-high-bits ,arg) new-args) (new-args `(double-float-high-bits ,arg))
(push '(signed-byte 32) new-types) (new-arg-types (parse-alien-type '(unsigned 32)))
(push `(double-float-low-bits ,arg) new-args) (new-arg-types (parse-alien-type '(signed 32))))
(push '(unsigned-byte 32) new-types)) (t
(t (new-args arg)
(push arg new-args) (new-arg-types type)))))
(push type new-types))))) `(lambda (function type ,@(lambda-vars))
`(lambda (name return-type arg-types ,@(nreverse lambda-vars)) (declare (ignore type))
(declare (ignore name return-type arg-types)) (%alien-funcall function
(ext::call-foreign-function ,name ',return-type ',(alien::make-alien-function-type
',(nreverse new-types) :arg-types (new-arg-types)
,@(nreverse new-args)))) :result-type result-type)
,@(new-args))))
(c::give-up)))) (c::give-up))))
(define-vop (foreign-symbol-address) (define-vop (foreign-symbol-address)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:info foreign-symbol) (:info foreign-symbol)
(:results (res :scs (sap-reg))) (:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2 (:generator 2
(inst li res (make-fixup (concatenate 'simple-string "_" foreign-symbol) (inst li res (make-fixup (concatenate 'simple-string "_" foreign-symbol)
:foreign)))) :foreign))))
(define-vop (call-out) (define-vop (call-out)
(:args (args :more t)) (:args (function :scs (sap-reg) :target cfunc)
(args :more t))
(:results (results :more t)) (:results (results :more t))
(:ignore args results) (:ignore args results)
(:save-p t) (:save-p t)
(:info function) (:temporary (:sc any-reg :offset cfunc-offset
(:temporary (:sc any-reg :offset cfunc-offset :to (:result 0)) cfunc) :from (:argument 0) :to (:result 0)) cfunc)
(:temporary (:sc interior-reg :offset lip-offset) lip) (:temporary (:sc interior-reg :offset lip-offset) lip)
(:temporary (:scs (any-reg) :to (:result 0)) temp) (:temporary (:scs (any-reg) :to (:result 0)) temp)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
...@@ -124,8 +131,7 @@ ...@@ -124,8 +131,7 @@
(let ((cur-nfp (current-nfp-tn vop))) (let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp (when cur-nfp
(store-stack-tn nfp-save cur-nfp)) (store-stack-tn nfp-save cur-nfp))
(inst li cfunc (move cfunc function)
(make-fixup (concatenate 'simple-string "_" function) :foreign))
(inst li temp (make-fixup "_call_into_c" :foreign)) (inst li temp (make-fixup "_call_into_c" :foreign))
(inst jal lip temp) (inst jal lip temp)
(inst nop) (inst nop)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment