home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / c-call.lisp < prev    next >
Encoding:
Text File  |  1992-05-19  |  7.1 KB  |  218 lines
  1. ;;; -*- Package: RT -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public
  6. ;;; domain.  If you want to use this code or any part of CMU Common
  7. ;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: c-call.lisp,v 1.10 92/03/25 16:14:44 wlott Exp $
  11. ;;;
  12. ;;; This file contains the VOPs and other necessary machine specific support
  13. ;;; routines for call-out to C.
  14. ;;;
  15. ;;; Written by William Lott.
  16. ;;; Converted by Bill Chiles.
  17. ;;;
  18.  
  19. (in-package "RT")
  20. (use-package "ALIEN")
  21. (use-package "ALIEN-INTERNALS")
  22.  
  23.  
  24.  
  25. ;;;; Make-call-out-tns and support stuff.
  26.  
  27. (defun c-call-wired-tn (primitive-type sc-name offset)
  28.   (make-wired-tn (primitive-type-or-lose primitive-type)
  29.          (sc-number-or-lose sc-name)
  30.          offset))
  31.  
  32.  
  33. (defstruct arg-state
  34.   (offset 0))
  35.  
  36. (defun int-arg (state prim-type stack-sc)
  37.   ;; C expects 4 register args and the 5th arg at the top of the stack.
  38.   ;; We can't put args in registers, because we need those registers
  39.   ;; for something else.  So we put them just beyond the end of the
  40.   ;; stack and the trampoline code will move them into place.
  41.   (let ((frame-size (arg-state-offset state)))
  42.     (setf (arg-state-offset state) (1+ frame-size))
  43.     (c-call-wired-tn prim-type stack-sc frame-size)))
  44.  
  45. (defun int-result (state prim-type reg-sc)
  46.   (let ((reg-num (arg-state-offset state)))
  47.     (setf (arg-state-offset state) (1+ reg-num))
  48.     (c-call-wired-tn prim-type reg-sc reg-num)))
  49.  
  50. (def-alien-type-method (integer :arg-tn) (type state)
  51.   (if (alien-integer-type-signed type)
  52.       (int-arg state 'signed-byte-32 'signed-stack)
  53.       (int-arg state 'unsigned-byte-32 'unsigned-stack)))
  54.  
  55. (def-alien-type-method (integer :result-tn) (type state)
  56.   (if (alien-integer-type-signed type)
  57.       (int-result state 'signed-byte-32 'signed-reg)
  58.       (int-result state 'unsigned-byte-32 'unsigned-reg)))
  59.  
  60. (def-alien-type-method (system-area-pointer :arg-tn) (type state)
  61.   (declare (ignore type))
  62.   (int-arg state 'system-area-pointer 'sap-stack))
  63.  
  64. (def-alien-type-method (system-area-pointer :result-tn) (type state)
  65.   (declare (ignore type))
  66.   (int-result state 'system-area-pointer 'sap-reg))
  67.  
  68. (def-alien-type-method (values :result-tn) (type state)
  69.   (mapcar #'(lambda (type)
  70.           (invoke-alien-type-method :result-tn type state))
  71.       (alien-values-type-values type)))
  72.  
  73. (def-vm-support-routine make-call-out-tns (type)
  74.   (declare (type alien-function-type type))
  75.   (let ((arg-state (make-arg-state)))
  76.     (collect ((arg-tns))
  77.       (dolist (arg-type (alien-function-type-arg-types type))
  78.     (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
  79.       (values (c-call-wired-tn 'positive-fixnum 'word-pointer-reg nsp-offset)
  80.           (* (arg-state-offset arg-state) word-bytes)
  81.           (arg-tns)
  82.           (invoke-alien-type-method
  83.            :result-tn
  84.            (alien-function-type-result-type type)
  85.            (make-arg-state :offset nl0-offset))))))
  86.  
  87.  
  88. ;;;; Deftransforms to convert uses of %alien-funcall into cononical form.
  89.  
  90. (deftransform %alien-funcall ((function type &rest args)
  91.                   (t * &rest t))
  92.   (assert (c::constant-continuation-p type))
  93.   (let* ((type (c::continuation-value type))
  94.      (arg-types (alien-function-type-arg-types type))
  95.      (result-type (alien-function-type-result-type type)))
  96.     (assert (= (length arg-types) (length args)))
  97.     (if (some #'alien-double-float-type-p arg-types)
  98.     (collect ((new-args) (lambda-vars) (new-arg-types))
  99.       (dolist (type arg-types)
  100.         (let ((arg (gensym)))
  101.           (lambda-vars arg)
  102.           (typecase type
  103.         (alien-double-float-type
  104.          (new-args `(double-float-high-bits ,arg))
  105.          (new-args `(double-float-low-bits ,arg))
  106.          (new-arg-types (parse-alien-type '(signed 32)))
  107.          (new-arg-types (parse-alien-type '(unsigned 32))))
  108.         (t
  109.          (new-args arg)
  110.          (new-arg-types type)))))
  111.       `(lambda (function type ,@(lambda-vars))
  112.          (declare (ignore type))
  113.          (%alien-funcall function
  114.                  ',(make-alien-function-type
  115.                 :arg-types (new-arg-types)
  116.                 :result-type result-type)
  117.                  ,@(new-args))))
  118.     (c::give-up))))
  119.  
  120. (deftransform %alien-funcall ((function type &rest args)
  121.                   (* t &rest t))
  122.   (assert (c::constant-continuation-p type))
  123.   (let* ((type (c::continuation-value type))
  124.      (arg-types (alien-function-type-arg-types type))
  125.      (result-type (alien-function-type-result-type type)))
  126.     (assert (= (length arg-types) (length args)))
  127.     (flet ((make-arg-name-list ()
  128.          (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
  129.              arg-types)))
  130.       (typecase result-type
  131.     (alien-double-float-type
  132.      (let ((arg-names (make-arg-name-list)))
  133.        `(lambda (function type ,@arg-names)
  134.           (declare (ignore type))
  135.           (multiple-value-bind
  136.           (hi lo)
  137.           (%alien-funcall function
  138.                   ',(make-alien-function-type
  139.                      :arg-types arg-types
  140.                      :result-type
  141.                      (let ((*values-type-okay* t))
  142.                        (parse-alien-type
  143.                     '(values (signed 32)
  144.                          (unsigned 32)))))
  145.                   ,@arg-names)
  146.           (make-double-float hi lo)))))
  147.     (alien-single-float-type
  148.      (let ((arg-names (make-arg-name-list)))
  149.        `(lambda (function type ,@arg-names)
  150.           (declare (ignore type))
  151.           (make-single-float
  152.            (%alien-funcall function
  153.                    ',(parse-alien-type
  154.                   `(function (signed 32) ,@arg-types))
  155.                    ,@arg-names)))))
  156.     (t
  157.      (c::give-up))))))
  158.  
  159.  
  160. ;;;; Vops.
  161.  
  162.  
  163. (define-vop (foreign-symbol-address)
  164.   (:translate foreign-symbol-address)
  165.   (:policy :fast-safe)
  166.   (:args)
  167.   (:arg-types (:constant simple-string))
  168.   (:info foreign-symbol)
  169.   (:results (res :scs (sap-reg)))
  170.   (:result-types system-area-pointer)
  171.   (:generator 2
  172.     (inst cai res (make-fixup (concatenate 'simple-string "_" foreign-symbol)
  173.                   :foreign))))
  174.  
  175. (define-vop (call-out)
  176.   (:args (function :scs (sap-reg) :target nl0)
  177.      (args :more t))
  178.   (:results (results :more t))
  179.   (:ignore args results)
  180.   (:save-p t)
  181.   (:temporary (:sc any-reg :offset nl0-offset
  182.            :from (:argument 0) :to (:result 0)) nl0)
  183.   (:temporary (:sc any-reg :offset lra-offset) lra)
  184.   (:temporary (:sc any-reg :offset code-offset) code)
  185.   (:temporary (:scs (sap-reg) :to (:result 0)) temp)
  186.   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
  187.   (:vop-var vop)
  188.   (:generator 0
  189.     (let ((lra-label (gen-label))
  190.       (cur-nfp (current-nfp-tn vop)))
  191.       (move nl0 function)
  192.       (when cur-nfp
  193.     (store-stack-tn cur-nfp nfp-save))
  194.       (inst compute-lra-from-code lra code lra-label)
  195.       (inst cai temp (make-fixup "call_into_c" :foreign))
  196.       (inst b temp)
  197.  
  198.       (align vm:lowtag-bits)
  199.       (emit-label lra-label)
  200.       (inst lra-header-word)
  201.       (when cur-nfp
  202.     (load-stack-tn cur-nfp nfp-save)))))
  203.  
  204. (define-vop (alloc-number-stack-space)
  205.   (:info amount)
  206.   (:results (result :scs (sap-reg any-reg)))
  207.   (:generator 0
  208.     (unless (zerop amount)
  209.       (inst cal nsp-tn nsp-tn (- (logandc2 (+ amount 7) 7))))
  210.     (move result nsp-tn)))
  211.  
  212. (define-vop (dealloc-number-stack-space)
  213.   (:info amount)
  214.   (:policy :fast-safe)
  215.   (:generator 0
  216.     (unless (zerop amount)
  217.       (inst cal nsp-tn  nsp-tn (logandc2 (+ amount 7) 7)))))
  218.