src/compiler/mips/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   (stack-frame-size 0)
  10   (did-int-arg nil)
  11   (float-args 0))
  12
  13 (define-alien-type-method (integer :arg-tn) (type state)
  14   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  15     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  16     (setf (arg-state-did-int-arg state) t)
  17     (multiple-value-bind
  18         (ptype reg-sc stack-sc)
  19         (if (alien-integer-type-signed type)
  20             (values 'signed-byte-32 'signed-reg 'signed-stack)
  21             (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
  22       (if (< stack-frame-size 4)
  23           (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4))
  24           (my-make-wired-tn ptype stack-sc stack-frame-size)))))
  25
  26 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  27   (declare (ignore type))
  28   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  29     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  30     (setf (arg-state-did-int-arg state) t)
  31     (if (< stack-frame-size 4)
  32         (my-make-wired-tn 'system-area-pointer
  33                           'sap-reg
  34                           (+ stack-frame-size 4))
  35         (my-make-wired-tn 'system-area-pointer
  36                           'sap-stack
  37                           stack-frame-size))))
  38
  39 (define-alien-type-method (double-float :arg-tn) (type state)
  40   (declare (ignore type))
  41   (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
  42         (float-args (arg-state-float-args state)))
  43     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
  44     (setf (arg-state-float-args state) (1+ float-args))
  45     (cond ((>= stack-frame-size 4)
  46            (my-make-wired-tn 'double-float
  47                              'double-stack
  48                              stack-frame-size))
  49           ((and (not (arg-state-did-int-arg state))
  50                 (< float-args 2))
  51            (my-make-wired-tn 'double-float
  52                              'double-reg
  53                              (+ (* float-args 2) 12)))
  54           (t
  55            (my-make-wired-tn 'double-float
  56                              'double-int-carg-reg
  57                              (+ stack-frame-size 4))))))
  58
  59 (define-alien-type-method (single-float :arg-tn) (type state)
  60   (declare (ignore type))
  61   (let ((stack-frame-size (arg-state-stack-frame-size state))
  62         (float-args (arg-state-float-args state)))
  63     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  64     (setf (arg-state-float-args state) (1+ float-args))
  65     (cond ((>= stack-frame-size 4)
  66            (my-make-wired-tn 'single-float
  67                              'single-stack
  68                              stack-frame-size))
  69           ((and (not (arg-state-did-int-arg state))
  70                 (< float-args 2))
  71            (my-make-wired-tn 'single-float
  72                              'single-reg
  73                              (+ (* float-args 2) 12)))
  74           (t
  75            (my-make-wired-tn 'single-float
  76                              'single-int-carg-reg
  77                              (+ stack-frame-size 4))))))
  78
  79
  80 (defstruct result-state
  81   (num-results 0))
  82
  83 (defun offset-for-result (n)
  84   (+ n 2)
  85   #+nil
  86   (if (= n 0)
  87       cfunc-offset
  88       (+ n 2)))
  89
  90 (define-alien-type-method (integer :result-tn) (type state)
  91   (let ((num-results (result-state-num-results state)))
  92     (setf (result-state-num-results state) (1+ num-results))
  93     (multiple-value-bind
  94         (ptype reg-sc)
  95         (if (alien-integer-type-signed type)
  96             (values 'signed-byte-32 'signed-reg)
  97             (values 'unsigned-byte-32 'unsigned-reg))
  98       (my-make-wired-tn ptype reg-sc (offset-for-result num-results)))))
  99
 100 (define-alien-type-method (system-area-pointer :result-tn) (type state)
 101   (declare (ignore type))
 102   (let ((num-results (result-state-num-results state)))
 103     (setf (result-state-num-results state) (1+ num-results))
 104     (my-make-wired-tn 'system-area-pointer 'sap-reg (offset-for-result num-results))))
 105
 106 ;;; FIXME: do these still work? -- CSR, 2002-08-28
 107 (define-alien-type-method (double-float :result-tn) (type state)
 108   (declare (ignore type))
 109   (let ((num-results (result-state-num-results state)))
 110     (setf (result-state-num-results state) (1+ num-results))
 111     (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
 112
 113 (define-alien-type-method (single-float :result-tn) (type state)
 114   (declare (ignore type))
 115   (let ((num-results (result-state-num-results state)))
 116     (setf (result-state-num-results state) (1+ num-results))
 117     (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
 118
 119 (define-alien-type-method (values :result-tn) (type state)
 120   (mapcar #'(lambda (type)
 121               (invoke-alien-type-method :result-tn type state))
 122           (alien-values-type-values type)))
 123
 124 (!def-vm-support-routine make-call-out-tns (type)
 125   (let ((arg-state (make-arg-state)))
 126     (collect ((arg-tns))
 127       (dolist (arg-type (alien-fun-type-arg-types type))
 128         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 129       (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
 130               (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes)
 131               (arg-tns)
 132               (invoke-alien-type-method :result-tn
 133                                         (alien-fun-type-result-type type)
 134                                         (make-result-state))))))
 135
 136
 137 (define-vop (foreign-symbol-address)
 138   (:translate foreign-symbol-address)
 139   (:policy :fast-safe)
 140   (:args)
 141   (:arg-types (:constant simple-base-string))
 142   (:info foreign-symbol)
 143   (:results (res :scs (sap-reg)))
 144   (:result-types system-area-pointer)
 145   (:generator 2
 146     (inst li res (make-fixup foreign-symbol :foreign))))
 147
 148 (define-vop (call-out)
 149   (:args (function :scs (sap-reg) :target cfunc)
 150          (args :more t))
 151   (:results (results :more t))
 152   (:ignore args results)
 153   (:save-p t)
 154   (:temporary (:sc any-reg :offset cfunc-offset
 155                    :from (:argument 0) :to (:result 0)) cfunc)
 156   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 157   (:vop-var vop)
 158   (:generator 0
 159     (let ((cur-nfp (current-nfp-tn vop)))
 160       (when cur-nfp
 161         (store-stack-tn nfp-save cur-nfp))
 162       (move cfunc function)
 163       (inst jal (make-fixup "call_into_c" :foreign))
 164       (inst nop)
 165       (when cur-nfp
 166         (load-stack-tn cur-nfp nfp-save)))))
 167
 168 (define-vop (alloc-number-stack-space)
 169   (:info amount)
 170   (:results (result :scs (sap-reg any-reg)))
 171   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 172   (:generator 0
 173     (unless (zerop amount)
 174       (let ((delta (logandc2 (+ amount 7) 7)))
 175         (cond ((< delta (ash 1 15))
 176                (inst subu nsp-tn delta))
 177               (t
 178                (inst li temp delta)
 179                (inst subu nsp-tn temp)))))
 180     (move result nsp-tn)))
 181
 182 (define-vop (dealloc-number-stack-space)
 183   (:info amount)
 184   (:policy :fast-safe)
 185   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 186   (:generator 0
 187     (unless (zerop amount)
 188       (let ((delta (logandc2 (+ amount 7) 7)))
 189         (cond ((< delta (ash 1 15))
 190                (inst addu nsp-tn delta))
 191               (t
 192                (inst li temp delta)
 193                (inst addu nsp-tn temp)))))))