src/compiler/ppc/c-call.lisp

   1 ;;; routines for call-out to C.
   2 ;;;
   3 ;;; Written by William Lott.
   4 ;;;
   5 (in-package "SB!VM")
   6
   7 (defun my-make-wired-tn (prim-type-name sc-name offset)
   8   (make-wired-tn (primitive-type-or-lose prim-type-name)
   9                  (sc-number-or-lose sc-name)
  10                  offset))
  11
  12 (defstruct arg-state
  13   (gpr-args 0)
  14   (fpr-args 0)
  15   ;SVR4 [a]abi wants two words on stack (callee saved lr, backpointer).
  16   (stack-frame-size 2))
  17
  18 (defun int-arg (state prim-type reg-sc stack-sc)
  19   (let ((reg-args (arg-state-gpr-args state)))
  20     (cond ((< reg-args 8)
  21            (setf (arg-state-gpr-args state) (1+ reg-args))
  22            (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
  23           (t
  24            (let ((frame-size (arg-state-stack-frame-size state)))
  25              (setf (arg-state-stack-frame-size state) (1+ frame-size))
  26              (my-make-wired-tn prim-type stack-sc frame-size))))))
  27
  28 (define-alien-type-method (integer :arg-tn) (type state)
  29   (if (alien-integer-type-signed type)
  30       (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
  31       (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
  32
  33 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  34   (declare (ignore type))
  35   (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
  36
  37 ; If a single-float arg has to go on the stack, it's promoted to
  38 ; double.  That way, C programs can get subtle rounding errors
  39 ; when unrelated arguments are introduced.
  40
  41 (define-alien-type-method (single-float :arg-tn) (type state)
  42   (declare (ignore type))
  43   (let* ((fprs (arg-state-fpr-args state)))
  44     (cond ((< fprs 8)
  45            (incf (arg-state-fpr-args state))
  46            ; Assign outgoing FPRs starting at FP1
  47            (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
  48           (t
  49            (let* ((stack-offset (arg-state-stack-frame-size state)))
  50              (if (oddp stack-offset)
  51                (incf stack-offset))
  52              (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
  53              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
  54
  55 (define-alien-type-method (double-float :arg-tn) (type state)
  56   (declare (ignore type))
  57   (let* ((fprs (arg-state-fpr-args state)))
  58     (cond ((< fprs 8)
  59            (incf (arg-state-fpr-args state))
  60            ; Assign outgoing FPRs starting at FP1
  61            (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
  62           (t
  63            (let* ((stack-offset (arg-state-stack-frame-size state)))
  64              (if (oddp stack-offset)
  65                (incf stack-offset))
  66              (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
  67              (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
  68
  69 (define-alien-type-method (integer :result-tn) (type)
  70   (if (alien-integer-type-signed type)
  71       (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)
  72       (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)))
  73
  74
  75 (define-alien-type-method (system-area-pointer :result-tn) (type)
  76   (declare (ignore type))
  77   (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset))
  78
  79 (define-alien-type-method (single-float :result-tn) (type)
  80   (declare (ignore type))
  81   (my-make-wired-tn 'single-float 'single-reg 1))
  82
  83 (define-alien-type-method (double-float :result-tn) (type)
  84   (declare (ignore type))
  85   (my-make-wired-tn 'double-float 'double-reg 1))
  86
  87 (define-alien-type-method (values :result-tn) (type)
  88   (mapcar #'(lambda (type)
  89               (invoke-alien-type-method :result-tn type))
  90           (alien-values-type-values type)))
  91
  92
  93 (!def-vm-support-routine make-call-out-tns (type)
  94   (declare (type alien-fun-type 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 (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
 100               (* (arg-state-stack-frame-size arg-state) n-word-bytes)
 101               (arg-tns)
 102               (invoke-alien-type-method
 103                :result-tn
 104                (alien-fun-type-result-type type))))))
 105
 106
 107 (define-vop (foreign-symbol-address)
 108   (:translate foreign-symbol-address)
 109   (:policy :fast-safe)
 110   (:args)
 111   (:arg-types (:constant simple-string))
 112   (:info foreign-symbol)
 113   (:results (res :scs (sap-reg)))
 114   (:result-types system-area-pointer)
 115   (:generator 2
 116     (inst lr res  (make-fixup foreign-symbol :foreign))))
 117
 118 (define-vop (call-out)
 119   (:args (function :scs (sap-reg) :target cfunc)
 120          (args :more t))
 121   (:results (results :more t))
 122   (:ignore args results)
 123   (:save-p t)
 124   (:temporary (:sc any-reg :offset cfunc-offset
 125                    :from (:argument 0) :to (:result 0)) cfunc)
 126   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 127   (:temporary (:scs (non-descriptor-reg)) temp)
 128   (:vop-var vop)
 129   (:generator 0
 130     (let ((cur-nfp (current-nfp-tn vop)))
 131       (when cur-nfp
 132         (store-stack-tn nfp-save cur-nfp))
 133       (inst lr temp (make-fixup "call_into_c" :foreign))
 134       (inst mtctr temp)
 135       (move cfunc function)
 136       (inst bctrl)
 137       (when cur-nfp
 138         (load-stack-tn cur-nfp nfp-save)))))
 139
 140
 141 (define-vop (alloc-number-stack-space)
 142   (:info amount)
 143   (:results (result :scs (sap-reg any-reg)))
 144   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 145   (:generator 0
 146     (unless (zerop amount)
 147       (let ((delta (- (logandc2 (+ amount 8 7) 7))))
 148         (cond ((>= delta (ash -1 16))
 149                (inst stwu nsp-tn nsp-tn delta))
 150               (t
 151                (inst lr temp delta)
 152                (inst stwux  nsp-tn nsp-tn temp)))))
 153     (unless (location= result nsp-tn)
 154       ;; They are only location= when the result tn was allocated by
 155       ;; make-call-out-tns above, which takes the number-stack-displacement
 156       ;; into account itself.
 157       (inst addi result nsp-tn number-stack-displacement))))
 158
 159 (define-vop (dealloc-number-stack-space)
 160   (:info amount)
 161   (:policy :fast-safe)
 162   (:generator 0
 163     (unless (zerop amount)
 164       (let ((delta (logandc2 (+ amount 8 7) 7)))
 165         (cond ((< delta (ash 1 16))
 166                (inst addi nsp-tn nsp-tn delta))
 167               (t
 168                (inst lwz nsp-tn nsp-tn 0)))))))