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 4))))))
  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 4))))))
  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 (integer :naturalize-gen) (type alien)
  80   (if (<= (alien-type-bits type) 32)
  81       (if (alien-integer-type-signed type)
  82           `(sign-extend ,alien ,(alien-type-bits type))
  83           `(logand ,alien ,(1- (ash 1 (alien-type-bits type)))))
  84       alien))
  85
  86 (define-alien-type-method (system-area-pointer :result-tn) (type state)
  87   (declare (ignore type state))
  88   (my-make-wired-tn 'system-area-pointer 'sap-reg lip-offset))
  89
  90 (define-alien-type-method (double-float :result-tn) (type state)
  91   (declare (ignore type state))
  92   (my-make-wired-tn 'double-float 'double-reg lip-offset))
  93
  94 (define-alien-type-method (single-float :result-tn) (type state)
  95   (declare (ignore type state))
  96   (my-make-wired-tn 'single-float 'single-reg lip-offset))
  97
  98 (define-alien-type-method (values :result-tn) (type state)
  99   (let ((values (alien-values-type-values type)))
 100     (when (cdr values)
 101       (error "Too many result values from c-call."))
 102     (when values
 103       (invoke-alien-type-method :result-tn (car values) state))))
 104
 105 (defun make-call-out-tns (type)
 106   (let ((arg-state (make-arg-state)))
 107     (collect ((arg-tns))
 108       (dolist (arg-type (alien-fun-type-arg-types type))
 109         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 110       (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
 111               (* (max (- (logandc2 (1+ (arg-state-stack-frame-size arg-state)) 1) 4) 2)
 112                  n-word-bytes
 113                  #.(floor n-machine-word-bits n-word-bits))
 114               (arg-tns)
 115               (invoke-alien-type-method :result-tn
 116                                         (alien-fun-type-result-type type)
 117                                         nil)))))
 118
 119 (defknown sign-extend ((signed-byte 64) t) fixnum
 120     (foldable flushable movable))
 121
 122 (define-vop (sign-extend)
 123   (:translate sign-extend)
 124   (:policy :fast-safe)
 125   (:args (val :scs (signed-reg) :target res))
 126   (:arg-types signed-num (:constant fixnum))
 127   (:info size)
 128   (:results (res :scs (signed-reg)))
 129   (:result-types fixnum)
 130   (:generator 1
 131    (ecase size
 132      (8
 133       ;;(inst sextb val res) ;; Under what circumstances can we use this?
 134       (inst sll val 56 res)
 135       (inst sra res 56 res))
 136      (16
 137       ;;(inst sextw val res) ;; Under what circumstances can we use this?
 138       (inst sll val 48 res)
 139       (inst sra res 48 res))
 140      (32
 141       (inst sll val 32 res)
 142       (inst sra res 32 res)))))
 143
 144 #-sb-xc-host
 145 (defun sign-extend (x size)
 146   (declare (type (signed-byte 64) x))
 147   (ecase size
 148     (8 (sign-extend x size))
 149     (16 (sign-extend x size))
 150     (32 (sign-extend x size))))
 151
 152 #+sb-xc-host
 153 (defun sign-extend (x size)
 154   (if (logbitp (1- size) x)
 155       (dpb x (byte size 0) -1)
 156       x))
 157
 158 (define-vop (foreign-symbol-sap)
 159   (:translate foreign-symbol-sap)
 160   (:policy :fast-safe)
 161   (:args)
 162   (:arg-types (:constant simple-string))
 163   (:info foreign-symbol)
 164   (:results (res :scs (sap-reg)))
 165   (:result-types system-area-pointer)
 166   (:generator 2
 167     (inst li (make-fixup foreign-symbol :foreign) res)))
 168
 169 (define-vop (call-out)
 170   (:args (function :scs (sap-reg) :target cfunc)
 171          (args :more t))
 172   (:results (results :more t))
 173   (:ignore args results)
 174   (:save-p t)
 175   (:temporary (:sc any-reg :offset cfunc-offset
 176                    :from (:argument 0) :to (:result 0)) cfunc)
 177   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 178   (:temporary (:scs (non-descriptor-reg)) temp)
 179   (:vop-var vop)
 180   (:generator 0
 181     (let ((cur-nfp (sb!c::current-nfp-tn vop)))
 182       (when cur-nfp
 183         (store-stack-tn nfp-save cur-nfp))
 184       (move function cfunc)
 185       (inst li (make-fixup "call_into_c" :foreign) temp)
 186       (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign))
 187       (when cur-nfp
 188         (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))))
 189
 190 (define-vop (alloc-number-stack-space)
 191   (:info amount)
 192   (:results (result :scs (sap-reg any-reg)))
 193   (:result-types system-area-pointer)
 194   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 195   (:generator 0
 196     (unless (zerop amount)
 197       (let ((delta (logandc2 (+ amount 7) 7)))
 198         (cond ((< delta (ash 1 15))
 199                (inst lda nsp-tn (- delta) nsp-tn))
 200               (t
 201                (inst li delta temp)
 202                (inst subq nsp-tn temp nsp-tn)))))
 203     (move nsp-tn result)))
 204
 205 (define-vop (dealloc-number-stack-space)
 206   (:info amount)
 207   (:policy :fast-safe)
 208   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 209   (:generator 0
 210     (unless (zerop amount)
 211       (let ((delta (logandc2 (+ amount 7) 7)))
 212         (cond ((< delta (ash 1 15))
 213                (inst lda nsp-tn delta nsp-tn))
 214               (t
 215                (inst li delta temp)
 216                (inst addq nsp-tn temp nsp-tn)))))))