src/compiler/alpha/c-call.lisp

   1 ;;; -*- Package: ALPHA -*-
   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 domain.
   6 ;;;
   7
   8 ;;;
   9 ;;; **********************************************************************
  10 ;;;
  11 ;;; This file contains the VOPs and other necessary machine specific support
  12 ;;; routines for call-out to C.
  13 ;;;
  14 ;;; Written by William Lott.
  15 ;;; Converted by Sean Hallgren.
  16 ;;;
  17 (in-package "SB!VM")
  18
  19 (use-package "SB!ALIEN")
  20 (use-package "SB!ALIEN-INTERNALS")
  21
  22 (defun my-make-wired-tn (prim-type-name sc-name offset)
  23   (make-wired-tn (primitive-type-or-lose prim-type-name )
  24                  (sc-number-or-lose sc-name )
  25                  offset))
  26
  27 (defstruct arg-state
  28   (stack-frame-size 0))
  29
  30 (def-alien-type-method (integer :arg-tn) (type state)
  31   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  32     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  33     (multiple-value-bind
  34         (ptype reg-sc stack-sc)
  35         (if (alien-integer-type-signed type)
  36             (values 'signed-byte-64 'signed-reg 'signed-stack)
  37             (values 'unsigned-byte-64 'unsigned-reg 'unsigned-stack))
  38       (if (< stack-frame-size 4)
  39           (my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset))
  40           (my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4)))))))
  41
  42 (def-alien-type-method (system-area-pointer :arg-tn) (type state)
  43   (declare (ignore type))
  44   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  45     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  46     (if (< stack-frame-size 4)
  47         (my-make-wired-tn 'system-area-pointer
  48                           'sap-reg
  49                           (+ stack-frame-size nl0-offset))
  50         (my-make-wired-tn 'system-area-pointer
  51                           'sap-stack
  52                           (* 2 (- stack-frame-size 4))))))
  53
  54 (def-alien-type-method (double-float :arg-tn) (type state)
  55   (declare (ignore type))
  56   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  57     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  58     (if (< stack-frame-size 6)
  59         (my-make-wired-tn 'double-float
  60                           'double-reg
  61                           (+ stack-frame-size nl0-offset))
  62         (my-make-wired-tn 'double-float
  63                           'double-stack
  64                           (* 2 (- stack-frame-size 6))))))
  65
  66 (def-alien-type-method (single-float :arg-tn) (type state)
  67   (declare (ignore type))
  68   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  69     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  70     (if (< stack-frame-size 6)
  71         (my-make-wired-tn 'single-float
  72                           'single-reg
  73                           (+ stack-frame-size nl0-offset))
  74         (my-make-wired-tn 'single-float
  75                           'single-stack
  76                           (* 2 (- stack-frame-size 6))))))
  77
  78
  79
  80 (def-alien-type-method (integer :result-tn) (type state)
  81   (declare (ignore state))
  82   (multiple-value-bind
  83       (ptype reg-sc)
  84       (if (alien-integer-type-signed type)
  85           (values 'signed-byte-64 'signed-reg)
  86           (values 'unsigned-byte-64 'unsigned-reg))
  87     (my-make-wired-tn ptype reg-sc lip-offset)))
  88
  89 (def-alien-type-method (system-area-pointer :result-tn) (type state)
  90   (declare (ignore type state))
  91   (my-make-wired-tn 'system-area-pointer 'sap-reg lip-offset))
  92
  93 (def-alien-type-method (double-float :result-tn) (type state)
  94   (declare (ignore type state))
  95   (my-make-wired-tn 'double-float 'double-reg lip-offset))
  96
  97 (def-alien-type-method (single-float :result-tn) (type state)
  98   (declare (ignore type state))
  99   (my-make-wired-tn 'single-float 'single-reg lip-offset))
 100
 101 (def-alien-type-method (values :result-tn) (type state)
 102   (let ((values (alien-values-type-values type)))
 103     (when (cdr values)
 104       (error "Too many result values from c-call."))
 105     (when values
 106       (invoke-alien-type-method :result-tn (car values) state))))
 107
 108 (!def-vm-support-routine make-call-out-tns (type)
 109   (let ((arg-state (make-arg-state)))
 110     (collect ((arg-tns))
 111       (dolist (arg-type (alien-function-type-arg-types type))
 112         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 113       (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
 114               (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes)
 115               (arg-tns)
 116               (invoke-alien-type-method :result-tn
 117                                         (alien-function-type-result-type type)
 118                                         nil)))))
 119
 120
 121 (define-vop (foreign-symbol-address)
 122   (:translate foreign-symbol-address)
 123   (:policy :fast-safe)
 124   (:args)
 125   (:arg-types (:constant simple-string))
 126   (:info foreign-symbol)
 127   (:results (res :scs (sap-reg)))
 128   (:result-types system-area-pointer)
 129   (:generator 2
 130     (inst li (make-fixup foreign-symbol :foreign) res)))
 131
 132 (define-vop (call-out)
 133   (:args (function :scs (sap-reg) :target cfunc)
 134          (args :more t))
 135   (:results (results :more t))
 136   (:ignore args results)
 137   (:save-p t)
 138   (:temporary (:sc any-reg :offset cfunc-offset
 139                    :from (:argument 0) :to (:result 0)) cfunc)
 140   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 141   (:temporary (:scs (non-descriptor-reg)) temp)
 142   (:vop-var vop)
 143   (:generator 0
 144     (let ((cur-nfp (sb!c::current-nfp-tn vop)))
 145       (when cur-nfp
 146         (store-stack-tn nfp-save cur-nfp))
 147       (move function cfunc)
 148       (inst li (make-fixup "call_into_c" :foreign) temp)
 149       (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign))
 150       (when cur-nfp
 151         (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))))
 152
 153 (define-vop (alloc-number-stack-space)
 154   (:info amount)
 155   (:results (result :scs (sap-reg any-reg)))
 156   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 157   (:generator 0
 158     (unless (zerop amount)
 159       (let ((delta (logandc2 (+ amount 7) 7)))
 160         (cond ((< delta (ash 1 15))
 161                (inst lda nsp-tn (- delta) nsp-tn))
 162               (t
 163                (inst li delta temp)
 164                (inst subq nsp-tn temp nsp-tn)))))
 165     (move nsp-tn result)))
 166
 167 (define-vop (dealloc-number-stack-space)
 168   (:info amount)
 169   (:policy :fast-safe)
 170   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 171   (:generator 0
 172     (unless (zerop amount)
 173       (let ((delta (logandc2 (+ amount 7) 7)))
 174         (cond ((< delta (ash 1 15))
 175                (inst lda nsp-tn delta nsp-tn))
 176               (t
 177                (inst li delta temp)
 178                (inst addq nsp-tn temp nsp-tn)))))))