src/compiler/arm/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 (defconstant +number-stack-allocation-granularity+ n-word-bytes)
  15
  16 (defconstant +max-register-args+ 4)
  17
  18 (defun my-make-wired-tn (prim-type-name sc-name offset)
  19   (make-wired-tn (primitive-type-or-lose prim-type-name )
  20                  (sc-number-or-lose sc-name )
  21                  offset))
  22
  23 (defstruct arg-state
  24   (num-register-args 0)
  25   (stack-frame-size 0))
  26
  27 (defun register-args-offset (index)
  28   (elt '(#.ocfp-offset #.nargs-offset #.nl2-offset #.nl3-offset)
  29        index))
  30
  31 (defun int-arg (state prim-type reg-sc stack-sc)
  32   (let ((reg-args (arg-state-num-register-args state)))
  33     (cond ((< reg-args +max-register-args+)
  34            (setf (arg-state-num-register-args state) (1+ reg-args))
  35            (my-make-wired-tn prim-type reg-sc (register-args-offset reg-args)))
  36           (t
  37            (error "Don't know how to allocate stack arguments")
  38            #+(or)
  39            (let ((frame-size (arg-state-stack-frame-size state)))
  40              (setf (arg-state-stack-frame-size state) (1+ frame-size))
  41              (my-make-wired-tn prim-type stack-sc frame-size))))))
  42
  43 (define-alien-type-method (integer :arg-tn) (type state)
  44   (if (alien-integer-type-signed type)
  45       (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
  46       (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
  47
  48 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  49   (declare (ignore type))
  50   (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
  51
  52 (define-alien-type-method (integer :result-tn) (type state)
  53   (declare (ignore state))
  54   (multiple-value-bind
  55       (ptype reg-sc)
  56       (if (alien-integer-type-signed type)
  57           (values 'signed-byte-32 'signed-reg)
  58           (values 'unsigned-byte-32 'unsigned-reg))
  59     (my-make-wired-tn ptype reg-sc nargs-offset)))
  60
  61 (define-alien-type-method (system-area-pointer :result-tn) (type state)
  62   (declare (ignore type state))
  63   (my-make-wired-tn 'system-area-pointer 'sap-reg nargs-offset))
  64
  65 (define-alien-type-method (values :result-tn) (type state)
  66   (let ((values (alien-values-type-values type)))
  67     (when (cdr values)
  68       (error "Too many result values from c-call."))
  69     (when values
  70       (invoke-alien-type-method :result-tn (car values) state))))
  71
  72 (defun make-call-out-tns (type)
  73   (let ((arg-state (make-arg-state)))
  74     (collect ((arg-tns))
  75       (dolist (arg-type (alien-fun-type-arg-types type))
  76         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
  77       (values (make-normal-tn *fixnum-primitive-type*)
  78               (* (arg-state-stack-frame-size arg-state) n-word-bytes)
  79               (arg-tns)
  80               (invoke-alien-type-method :result-tn
  81                                         (alien-fun-type-result-type type)
  82                                         nil)))))
  83 \f
  84 (define-vop (foreign-symbol-sap)
  85   (:translate foreign-symbol-sap)
  86   (:policy :fast-safe)
  87   (:args)
  88   (:arg-types (:constant simple-string))
  89   (:info foreign-symbol)
  90   (:temporary (:sc interior-reg) lip)
  91   (:results (res :scs (sap-reg)))
  92   (:result-types system-area-pointer)
  93   (:generator 2
  94     (let ((fixup-label (gen-label)))
  95       (inst load-from-label res lip fixup-label)
  96       (assemble (*elsewhere*)
  97         (emit-label fixup-label)
  98         (inst word (make-fixup foreign-symbol :foreign))))))
  99
 100 (define-vop (call-out)
 101   (:args (function :scs (sap-reg) :target cfunc)
 102          (args :more t))
 103   (:results (results :more t))
 104   (:ignore args results)
 105   (:save-p t)
 106   (:temporary (:sc any-reg :offset r8-offset
 107                    :from (:argument 0) :to (:result 0)) cfunc)
 108   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 109   (:temporary (:scs (non-descriptor-reg)) temp)
 110   (:temporary (:sc interior-reg) lip)
 111   (:vop-var vop)
 112   (:generator 0
 113     (let ((call-into-c-fixup (gen-label))
 114           (cur-nfp (current-nfp-tn vop)))
 115       (assemble (*elsewhere*)
 116         (emit-label call-into-c-fixup)
 117         (inst word (make-fixup "call_into_c" :foreign)))
 118       (when cur-nfp
 119         (store-stack-tn nfp-save cur-nfp))
 120       (inst load-from-label temp lip call-into-c-fixup)
 121       (move cfunc function)
 122       (inst blx temp)
 123       (when cur-nfp
 124         (load-stack-tn cur-nfp nfp-save)))))
 125
 126 (define-vop (alloc-number-stack-space)
 127   (:info amount)
 128   (:result-types system-area-pointer)
 129   (:results (result :scs (sap-reg any-reg)))
 130   (:generator 0
 131     (load-symbol-value result *number-stack-pointer*)
 132     (unless (zerop amount)
 133       (let ((delta (logandc2 (+ amount (1- +number-stack-allocation-granularity+))
 134                              (1- +number-stack-allocation-granularity+))))
 135         (inst sub result result delta)
 136         (store-symbol-value result *number-stack-pointer*)))))
 137
 138 (define-vop (dealloc-number-stack-space)
 139   (:info amount)
 140   (:policy :fast-safe)
 141   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 142   (:generator 0
 143     (unless (zerop amount)
 144       (let ((delta (logandc2 (+ amount (1- +number-stack-allocation-granularity+))
 145                              (1- +number-stack-allocation-granularity+))))
 146         (load-symbol-value temp *number-stack-pointer*)
 147         (inst add temp temp delta)
 148         (store-symbol-value temp *number-stack-pointer*)))))