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

New-aliens changes.

parent a952f260
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU) ;;; 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 ;;; This file contains the VOPs and other necessary machine specific support
;;; routines for call-out to C. ;;; routines for call-out to C.
...@@ -19,133 +19,163 @@ ...@@ -19,133 +19,163 @@
(in-package "RT") (in-package "RT")
;;;; Make-call-out-argument-tns and support stuff.
(defun c-call-wired-tn (primitive-type sc-name offset) (defun c-call-wired-tn (primitive-type sc-name offset)
(make-wired-tn (primitive-type-or-lose primitive-type) (make-wired-tn (primitive-type-or-lose primitive-type)
(sc-number-or-lose sc-name) (sc-number-or-lose sc-name)
offset)) offset))
(def-vm-support-routine make-call-out-nsp-tn ()
(c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset)) (defstruct arg-state
(stack-frame-size 0))
(def-vm-support-routine make-call-out-argument-tns (arg-types) (defun int-arg (state prim-type stack-sc)
(let ((nargs 0)) ;; C expects 4 register args and the 5th arg at the top of the stack.
(collect ((tns)) ;; We can't put args in registers, because we need those registers
(dolist (type arg-types) ;; for something else. So we put them just beyond the end of the
(multiple-value-bind ;; stack and the trampoline code will move them into place.
(ptype reg-sc stack-sc) (let ((frame-size (arg-state-stack-frame-size state)))
(ecase (if (consp type) (car type) type) (setf (arg-state-stack-frame-size state) (1+ frame-size))
((unsigned-byte port) (c-call-wired-tn prim-type stack-sc frame-size)))
(values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
(signed-byte (defun int-result (state prim-type reg-sc)
(values 'signed-byte-32 'signed-reg 'signed-stack)) (let ((reg-num (arg-state-stack-frame-size state)))
(system-area-pointer (setf (arg-state-stack-frame-size state) (1+ reg-num))
(values 'system-area-pointer 'sap-reg 'sap-stack))) (c-call-wired-tn prim-type reg-sc reg-num)))
;; 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 (def-alien-type-method (integer :arg-tn) (type state)
;; for something else. So we put them just beyond the end of the (if (alien-integer-type-signed type)
;; stack and the trampoline code will move them into place. (int-arg state 'signed-byte-32 'signed-stack)
(tns (c-call-wired-tn ptype stack-sc nargs)) (int-arg state 'unsigned-byte-32 'unsigned-stack)))
(incf nargs)))
(values (tns) (def-alien-type-method (integer :result-tn) (type state)
(* nargs word-bytes))))) (if (alien-integer-type-signed type)
(int-result state 'signed-byte-32 'signed-reg)
(def-vm-support-routine make-call-out-result-tn (type) (int-result state 'unsigned-byte-32 'unsigned-reg)))
(let ((offset nl0-offset))
(labels (def-alien-type-method (alien::sap :arg-tn) (type state)
((frob (type) (declare (ignore type))
(let ((name (if (consp type) (car type) type))) (int-arg state 'system-area-pointer 'sap-stack))
(prog1
(ecase name (def-alien-type-method (alien::sap :result-tn) (type state)
((unsigned-byte port) (declare (ignore type))
(c-call-wired-tn 'unsigned-byte-32 'unsigned-reg offset)) (int-result state 'system-area-pointer 'sap-reg))
(signed-byte
(c-call-wired-tn 'signed-byte-32 'signed-reg offset)) (def-alien-type-method (values :result-tn) (type state)
(system-area-pointer (mapcar #'(lambda (type)
(c-call-wired-tn 'system-area-pointer 'sap-reg offset)) (invoke-alien-type-method :result-tn type state))
(values (alien-values-type-values type)))
(when (consp type)
(mapcar #'frob (cdr type))))) (def-vm-support-routine make-call-out-argument-tns (type)
(incf offset))))) (declare (type alien-function-type type))
(frob type)))) (let ((arg-state (make-arg-state)))
(collect ((arg-tns))
(deftransform ext::call-foreign-function (dolist (arg-type (alien-function-type-arg-types type))
((name return-type arg-types &rest args) (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(string * list &rest t)) (values (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset)
(assert (c::constant-continuation-p name)) (* (arg-state-stack-frame-size arg-state) word-bytes)
(assert (c::constant-continuation-p return-type)) (arg-tns)
(assert (c::constant-continuation-p arg-types)) (invoke-alien-type-method
(let ((name (c::continuation-value name)) :result-tn
(return-type (c::continuation-value return-type)) (alien-function-type-result-type type)
(arg-types (c::continuation-value arg-types))) (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))) (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 (typecase type
(double-float (alien::alien-double-float-type
(push `(double-float-high-bits ,arg) new-args) (new-args `(double-float-high-bits ,arg))
(push '(signed-byte 32) new-types) (new-args `(double-float-low-bits ,arg))
(push `(double-float-low-bits ,arg) new-args) (new-arg-types (parse-alien-type '(signed 32)))
(push '(unsigned-byte 32) new-types)) (new-arg-types (parse-alien-type '(unsigned 32))))
(t (t
(push arg new-args) (new-args arg)
(push type new-types))))) (new-arg-types type)))))
`(lambda (name return-type arg-types ,@(nreverse lambda-vars)) `(lambda (function type ,@(lambda-vars))
(declare (ignore name return-type arg-types)) (declare (ignore type))
(ext::call-foreign-function ,name ',return-type (%alien-funcall function
',(nreverse new-types) ',(alien::make-alien-function-type
,@(nreverse new-args)))) :arg-types (new-arg-types)
:result-type result-type)
,@(new-args))))
(c::give-up)))) (c::give-up))))
(deftransform ext::call-foreign-function (deftransform %alien-funcall ((function type &rest args)
((name return-type arg-types &rest args) (* t &rest t))
(string t * &rest t)) (assert (c::constant-continuation-p type))
(assert (c::constant-continuation-p name)) (let* ((type (c::continuation-value type))
(assert (c::constant-continuation-p return-type)) (arg-types (alien-function-type-arg-types type))
(assert (c::constant-continuation-p arg-types)) (result-type (alien-function-type-result-type type)))
(let ((name (c::continuation-value name)) (assert (= (length arg-types) (length args)))
(return-type (c::continuation-value return-type)) (flet ((make-arg-name-list ()
(arg-types (c::continuation-value arg-types)) (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
(arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args))) arg-types)))
(case return-type (typecase result-type
(double-float (alien::alien-double-float-type
`(lambda (name return-type arg-types ,@arg-names) (let ((arg-names (make-arg-name-list)))
(declare (ignore name return-type arg-types)) `(lambda (function type ,@arg-names)
(multiple-value-bind (declare (ignore type))
(hi lo) (multiple-value-bind
(ext::call-foreign-function ,name (hi lo)
'(values signed-byte unsigned-byte) (%alien-funcall function
',arg-types ',(parse-alien-type
,@arg-names) `(function (values (signed 32)
(make-double-float hi lo)))) (unsigned 32))
(single-float ,@arg-types))
`(lambda (name return-type arg-types ,@arg-names) ,@arg-names)
(make-single-float (make-double-float hi lo)))))
(ext::call-foreign-function ,name 'signed-byte ',arg-types (alien::alien-single-float-type
,@arg-names)))) (let ((arg-names (make-arg-name-list)))
(t `(lambda (function type ,@arg-names)
(c::give-up))))) (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) (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 cai res (make-fixup (concatenate 'simple-string "_" foreign-symbol) (inst cai 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 nl0)
(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) (: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 lra-offset) lra)
(:temporary (:sc any-reg :offset code-offset) code) (:temporary (:sc any-reg :offset code-offset) code)
(:temporary (:scs (sap-reg) :to (:result 0)) temp) (:temporary (:scs (sap-reg) :to (:result 0)) temp)
...@@ -154,11 +184,10 @@ ...@@ -154,11 +184,10 @@
(:generator 0 (:generator 0
(let ((lra-label (gen-label)) (let ((lra-label (gen-label))
(cur-nfp (current-nfp-tn vop))) (cur-nfp (current-nfp-tn vop)))
(move nl0 function)
(when cur-nfp (when cur-nfp
(store-stack-tn cur-nfp nfp-save)) (store-stack-tn cur-nfp nfp-save))
(inst compute-lra-from-code lra code lra-label) (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 cai temp (make-fixup "call_into_c" :foreign))
(inst b temp) (inst b temp)
......
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