src/compiler/hppa/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   (args 0))
  21
  22 (defstruct (arg-info
  23             (:constructor make-arg-info (offset prim-type reg-sc stack-sc)))
  24   offset
  25   prim-type
  26   reg-sc
  27   stack-sc)
  28
  29 (define-alien-type-method (integer :arg-tn) (type state)
  30   (let ((args (arg-state-args state)))
  31     (setf (arg-state-args state) (1+ args))
  32     (if (alien-integer-type-signed type)
  33         (make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack)
  34         (make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))))
  35
  36 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  37   (declare (ignore type))
  38   (let ((args (arg-state-args state)))
  39     (setf (arg-state-args state) (1+ args))
  40     (make-arg-info args 'system-area-pointer 'sap-reg 'sap-stack)))
  41
  42 (define-alien-type-method (single-float :arg-tn) (type state)
  43   (declare (ignore type))
  44   (let ((args (arg-state-args state)))
  45     (setf (arg-state-args state) (1+ args))
  46     (make-arg-info args 'single-float 'single-reg 'single-stack)))
  47
  48 (define-alien-type-method (double-float :arg-tn) (type state)
  49   (declare (ignore type))
  50   (let ((args (logior (1+ (arg-state-args state)) 1)))
  51     (setf (arg-state-args state) (1+ args))
  52     (make-arg-info args 'double-float 'double-reg 'double-stack)))
  53
  54 (define-alien-type-method (integer :result-tn) (type)
  55   (if (alien-integer-type-signed type)
  56       (my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset)
  57       (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset)))
  58
  59 (define-alien-type-method (system-area-pointer :result-tn) (type)
  60   (declare (ignore type))
  61   (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset))
  62
  63 (define-alien-type-method (single-float :result-tn) (type)
  64   (declare (ignore type))
  65   (my-make-wired-tn 'single-float 'single-reg 4))
  66
  67 (define-alien-type-method (double-float :result-tn) (type)
  68   (declare (ignore type))
  69   (my-make-wired-tn 'double-float 'double-reg 4))
  70
  71 (define-alien-type-method (values :result-tn) (type)
  72   (let ((values (alien-values-type-values type)))
  73     (when values
  74       (aver (null (cdr values)))
  75       (invoke-alien-type-method :result-tn (car values)))))
  76
  77 (defun make-arg-tns (type)
  78   (let* ((state (make-arg-state))
  79          (args (mapcar #'(lambda (arg-type)
  80                            (invoke-alien-type-method :arg-tn arg-type state))
  81                        (alien-fun-type-arg-types type)))
  82          ;; We need 8 words of cruft, and we need to round up to a multiple
  83          ;; of 16 words.
  84          (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15)))
  85     (values
  86      (mapcar #'(lambda (arg)
  87                  (declare (type arg-info arg))
  88                  (let ((offset (arg-info-offset arg))
  89                        (prim-type (arg-info-prim-type arg)))
  90                    (cond ((>= offset 4)
  91                           (my-make-wired-tn prim-type (arg-info-stack-sc arg)
  92                                             (- frame-size offset 8 1)))
  93                          ((or (eq prim-type 'single-float)
  94                               (eq prim-type 'double-float))
  95                           (my-make-wired-tn prim-type (arg-info-reg-sc arg)
  96                                             (+ offset 4)))
  97                          (t
  98                           (my-make-wired-tn prim-type (arg-info-reg-sc arg)
  99                                             (- nl0-offset offset))))))
 100              args)
 101      (* frame-size n-word-bytes))))
 102
 103 (!def-vm-support-routine make-call-out-tns (type)
 104   (declare (type alien-fun-type type))
 105   (multiple-value-bind
 106       (arg-tns stack-size)
 107       (make-arg-tns type)
 108     (values (make-normal-tn *fixnum-primitive-type*)
 109             stack-size
 110             arg-tns
 111             (invoke-alien-type-method
 112              :result-tn
 113              (alien-fun-type-result-type type)))))
 114
 115 (define-vop (foreign-symbol-address)
 116   (:translate foreign-symbol-address)
 117   (:policy :fast-safe)
 118   (:args)
 119   (:arg-types (:constant simple-string))
 120   (:info foreign-symbol)
 121   (:results (res :scs (sap-reg)))
 122   (:result-types system-area-pointer)
 123   (:generator 2
 124     (inst li (make-fixup foreign-symbol :foreign) res)))
 125
 126 (define-vop (call-out)
 127   (:args (function :scs (sap-reg) :target cfunc)
 128          (args :more t))
 129   (:results (results :more t))
 130   (:ignore args results)
 131   (:save-p t)
 132   (:temporary (:sc any-reg :offset cfunc-offset
 133                    :from (:argument 0) :to (:result 0)) cfunc)
 134   (:temporary (:scs (any-reg) :to (:result 0)) temp)
 135   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 136   (:vop-var vop)
 137   (:generator 0
 138     (let ((cur-nfp (current-nfp-tn vop)))
 139       (when cur-nfp
 140         (store-stack-tn nfp-save cur-nfp))
 141       (move function cfunc)
 142       (let ((fixup (make-fixup "call_into_c" :foreign)))
 143         (inst ldil fixup temp)
 144         (inst ble fixup c-text-space temp :nullify t))
 145       (inst nop)
 146       (when cur-nfp
 147         (load-stack-tn cur-nfp nfp-save)))))
 148
 149 (define-vop (alloc-number-stack-space)
 150   (:info amount)
 151   (:results (result :scs (sap-reg any-reg)))
 152   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 153   (:generator 0
 154     (move nsp-tn result)
 155     (unless (zerop amount)
 156       (let ((delta (logandc2 (+ amount 63) 63)))
 157         (cond ((< delta (ash 1 10))
 158                (inst addi delta nsp-tn nsp-tn))
 159               (t
 160                (inst li delta temp)
 161                (inst add temp nsp-tn nsp-tn)))))))
 162
 163 (define-vop (dealloc-number-stack-space)
 164   (:info amount)
 165   (:policy :fast-safe)
 166   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 167   (:generator 0
 168     (unless (zerop amount)
 169       (let ((delta (- (logandc2 (+ amount 63) 63))))
 170         (cond ((<= (- (ash 1 10)) delta)
 171                (inst addi delta nsp-tn nsp-tn))
 172               (t
 173                (inst li delta temp)
 174                (inst add temp nsp-tn nsp-tn)))))))