src/compiler/alpha/c-call.lisp

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