src/compiler/hppa/c-call.lisp

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