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 (defstruct arg-state
  15   (stack-frame-size 0))
  16
  17 (define-alien-type-method (integer :arg-tn) (type state)
  18   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  19     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  20     (multiple-value-bind
  21         (ptype reg-sc stack-sc)
  22         (if (alien-integer-type-signed type)
  23             (values 'signed-byte-64 signed-reg-sc-number signed-stack-sc-number)
  24             (values 'unsigned-byte-64 unsigned-reg-sc-number unsigned-stack-sc-number))
  25       (if (< stack-frame-size 4)
  26           (make-wired-tn* ptype reg-sc (+ stack-frame-size nl0-offset))
  27           (make-wired-tn* ptype stack-sc (* 2 (- stack-frame-size 4)))))))
  28
  29 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  30   (declare (ignore type))
  31   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  32     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  33     (if (< stack-frame-size 4)
  34         (make-wired-tn* 'system-area-pointer sap-reg-sc-number
  35                           (+ stack-frame-size nl0-offset))
  36         (make-wired-tn* 'system-area-pointer sap-stack-sc-number
  37                           (* 2 (- stack-frame-size 4))))))
  38
  39 (define-alien-type-method (double-float :arg-tn) (type state)
  40   (declare (ignore type))
  41   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  42     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  43     (if (< stack-frame-size 6)
  44         (make-wired-tn* 'double-float double-reg-sc-number
  45                           (+ stack-frame-size nl0-offset))
  46         (make-wired-tn* 'double-float double-stack-sc-number
  47                           (* 2 (- stack-frame-size 4))))))
  48
  49 (define-alien-type-method (single-float :arg-tn) (type state)
  50   (declare (ignore type))
  51   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  52     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  53     (if (< stack-frame-size 6)
  54         (make-wired-tn* 'single-float single-reg-sc-number
  55                           (+ stack-frame-size nl0-offset))
  56         (make-wired-tn* 'single-float single-stack-sc-number
  57                           (* 2 (- stack-frame-size 4))))))
  58
  59 (define-alien-type-method (integer :result-tn) (type state)
  60   (declare (ignore state))
  61   (multiple-value-bind
  62       (ptype reg-sc)
  63       (if (alien-integer-type-signed type)
  64           (values 'signed-byte-64 signed-reg-sc-number)
  65           (values 'unsigned-byte-64 unsigned-reg-sc-number))
  66     (make-wired-tn* ptype reg-sc lip-offset)))
  67
  68 (define-alien-type-method (integer :naturalize-gen) (type alien)
  69   (if (<= (alien-type-bits type) 32)
  70       (if (alien-integer-type-signed type)
  71           `(sign-extend ,alien ,(alien-type-bits type))
  72           `(logand ,alien ,(1- (ash 1 (alien-type-bits type)))))
  73       alien))
  74
  75 (define-alien-type-method (system-area-pointer :result-tn) (type state)
  76   (declare (ignore type state))
  77   (make-wired-tn* 'system-area-pointer sap-reg-sc-number lip-offset))
  78
  79 (define-alien-type-method (double-float :result-tn) (type state)
  80   (declare (ignore type state))
  81   (make-wired-tn* 'double-float double-reg-sc-number lip-offset))
  82
  83 (define-alien-type-method (single-float :result-tn) (type state)
  84   (declare (ignore type state))
  85   (make-wired-tn* 'single-float single-reg-sc-number lip-offset))
  86
  87 (define-alien-type-method (values :result-tn) (type state)
  88   (let ((values (alien-values-type-values type)))
  89     (when (cdr values)
  90       (error "Too many result values from c-call."))
  91     (when values
  92       (invoke-alien-type-method :result-tn (car values) state))))
  93
  94 (defun make-call-out-tns (type)
  95   (let ((arg-state (make-arg-state)))
  96     (collect ((arg-tns))
  97       (dolist (arg-type (alien-fun-type-arg-types type))
  98         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
  99       (values (make-wired-tn* 'positive-fixnum any-reg-sc-number nsp-offset)
 100               (* (max (- (logandc2 (1+ (arg-state-stack-frame-size arg-state)) 1) 4) 2)
 101                  n-word-bytes
 102                  #.(floor n-machine-word-bits n-word-bits))
 103               (arg-tns)
 104               (invoke-alien-type-method :result-tn
 105                                         (alien-fun-type-result-type type)
 106                                         nil)))))
 107
 108 (defknown sign-extend ((signed-byte 64) t) fixnum
 109     (foldable flushable movable))
 110
 111 (define-vop (sign-extend)
 112   (:translate sign-extend)
 113   (:policy :fast-safe)
 114   (:args (val :scs (signed-reg) :target res))
 115   (:arg-types signed-num (:constant fixnum))
 116   (:info size)
 117   (:results (res :scs (signed-reg)))
 118   (:result-types fixnum)
 119   (:generator 1
 120    (ecase size
 121      (8
 122       ;;(inst sextb val res) ;; Under what circumstances can we use this?
 123       (inst sll val 56 res)
 124       (inst sra res 56 res))
 125      (16
 126       ;;(inst sextw val res) ;; Under what circumstances can we use this?
 127       (inst sll val 48 res)
 128       (inst sra res 48 res))
 129      (32
 130       (inst sll val 32 res)
 131       (inst sra res 32 res)))))
 132
 133 #-sb-xc-host
 134 (defun sign-extend (x size)
 135   (declare (type (signed-byte 64) x))
 136   (ecase size
 137     (8 (sign-extend x size))
 138     (16 (sign-extend x size))
 139     (32 (sign-extend x size))))
 140
 141 #+sb-xc-host
 142 (defun sign-extend (x size)
 143   (if (logbitp (1- size) x)
 144       (dpb x (byte size 0) -1)
 145       x))
 146
 147 (define-vop (foreign-symbol-sap)
 148   (:translate foreign-symbol-sap)
 149   (:policy :fast-safe)
 150   (:args)
 151   (:arg-types (:constant simple-string))
 152   (:info foreign-symbol)
 153   (:results (res :scs (sap-reg)))
 154   (:result-types system-area-pointer)
 155   (:generator 2
 156     (inst li (make-fixup foreign-symbol :foreign) res)))
 157
 158 (define-vop (call-out)
 159   (:args (function :scs (sap-reg) :target cfunc)
 160          (args :more t))
 161   (:results (results :more t))
 162   (:ignore args results)
 163   (:save-p t)
 164   (:temporary (:sc any-reg :offset cfunc-offset
 165                    :from (:argument 0) :to (:result 0)) cfunc)
 166   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 167   (:temporary (:scs (non-descriptor-reg)) temp)
 168   (:vop-var vop)
 169   (:generator 0
 170     (let ((cur-nfp (sb!c::current-nfp-tn vop)))
 171       (when cur-nfp
 172         (store-stack-tn nfp-save cur-nfp))
 173       (move function cfunc)
 174       (inst li (make-fixup "call_into_c" :foreign) temp)
 175       (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign))
 176       (when cur-nfp
 177         (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))))
 178
 179 (define-vop (alloc-number-stack-space)
 180   (:info amount)
 181   (:results (result :scs (sap-reg any-reg)))
 182   (:result-types system-area-pointer)
 183   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 184   (:generator 0
 185     (unless (zerop amount)
 186       (let ((delta (logandc2 (+ amount 7) 7)))
 187         (cond ((< delta (ash 1 15))
 188                (inst lda nsp-tn (- delta) nsp-tn))
 189               (t
 190                (inst li delta temp)
 191                (inst subq nsp-tn temp nsp-tn)))))
 192     (move nsp-tn result)))
 193
 194 (define-vop (dealloc-number-stack-space)
 195   (:info amount)
 196   (:policy :fast-safe)
 197   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 198   (:generator 0
 199     (unless (zerop amount)
 200       (let ((delta (logandc2 (+ amount 7) 7)))
 201         (cond ((< delta (ash 1 15))
 202                (inst lda nsp-tn delta nsp-tn))
 203               (t
 204                (inst li delta temp)
 205                (inst addq nsp-tn temp nsp-tn)))))))