src/compiler/x86/c-call.lisp

   1 ;;;; the VOPs and other necessary machine specific support
   2 ;;;; routines for call-out to C
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!VM")
  14
  15 (file-comment
  16  "$Header$")
  17
  18 ;; The move-argument vop is going to store args on the stack for
  19 ;; call-out. These tn's will be used for that. move-arg is normally
  20 ;; used for things going down the stack but C wants to have args
  21 ;; indexed in the positive direction.
  22
  23 (defun my-make-wired-tn (prim-type-name sc-name offset)
  24   (make-wired-tn (primitive-type-or-lose prim-type-name)
  25                  (sc-number-or-lose sc-name)
  26                  offset))
  27
  28 (defstruct arg-state
  29   (stack-frame-size 0))
  30
  31 (def-alien-type-method (integer :arg-tn) (type state)
  32   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  33     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  34     (multiple-value-bind (ptype stack-sc)
  35         (if (alien-integer-type-signed type)
  36             (values 'signed-byte-32 'signed-stack)
  37             (values 'unsigned-byte-32 'unsigned-stack))
  38       (my-make-wired-tn ptype stack-sc stack-frame-size))))
  39
  40 (def-alien-type-method (system-area-pointer :arg-tn) (type state)
  41   (declare (ignore type))
  42   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  43     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  44     (my-make-wired-tn 'system-area-pointer
  45                       'sap-stack
  46                       stack-frame-size)))
  47
  48 #!+long-float
  49 (def-alien-type-method (long-float :arg-tn) (type state)
  50   (declare (ignore type))
  51   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  52     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 3))
  53     (my-make-wired-tn 'long-float 'long-stack stack-frame-size)))
  54
  55 (def-alien-type-method (double-float :arg-tn) (type state)
  56   (declare (ignore type))
  57   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  58     (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
  59     (my-make-wired-tn 'double-float 'double-stack stack-frame-size)))
  60
  61 (def-alien-type-method (single-float :arg-tn) (type state)
  62   (declare (ignore type))
  63   (let ((stack-frame-size (arg-state-stack-frame-size state)))
  64     (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
  65     (my-make-wired-tn 'single-float 'single-stack stack-frame-size)))
  66
  67 (defstruct result-state
  68   (num-results 0))
  69
  70 (defun result-reg-offset (slot)
  71   (ecase slot
  72     (0 eax-offset)
  73     (1 edx-offset)))
  74
  75 (def-alien-type-method (integer :result-tn) (type state)
  76   (let ((num-results (result-state-num-results state)))
  77     (setf (result-state-num-results state) (1+ num-results))
  78     (multiple-value-bind (ptype reg-sc)
  79         (if (alien-integer-type-signed type)
  80             (values 'signed-byte-32 'signed-reg)
  81             (values 'unsigned-byte-32 'unsigned-reg))
  82       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
  83
  84 (def-alien-type-method (system-area-pointer :result-tn) (type state)
  85   (declare (ignore type))
  86   (let ((num-results (result-state-num-results state)))
  87     (setf (result-state-num-results state) (1+ num-results))
  88     (my-make-wired-tn 'system-area-pointer 'sap-reg
  89                       (result-reg-offset num-results))))
  90
  91 #!+long-float
  92 (def-alien-type-method (long-float :result-tn) (type state)
  93   (declare (ignore type))
  94   (let ((num-results (result-state-num-results state)))
  95     (setf (result-state-num-results state) (1+ num-results))
  96     (my-make-wired-tn 'long-float 'long-reg (* num-results 2))))
  97
  98 (def-alien-type-method (double-float :result-tn) (type state)
  99   (declare (ignore type))
 100   (let ((num-results (result-state-num-results state)))
 101     (setf (result-state-num-results state) (1+ num-results))
 102     (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
 103
 104 (def-alien-type-method (single-float :result-tn) (type state)
 105   (declare (ignore type))
 106   (let ((num-results (result-state-num-results state)))
 107     (setf (result-state-num-results state) (1+ num-results))
 108     (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
 109
 110 #+nil ;;pfw obsolete now?
 111 (def-alien-type-method (values :result-tn) (type state)
 112   (mapcar #'(lambda (type)
 113               (invoke-alien-type-method :result-tn type state))
 114           (alien-values-type-values type)))
 115
 116 ;;; pfw - from alpha
 117 (def-alien-type-method (values :result-tn) (type state)
 118   (let ((values (alien-values-type-values type)))
 119     (when (cdr values)
 120       (error "Too many result values from c-call."))
 121     (when values
 122       (invoke-alien-type-method :result-tn (car values) state))))
 123
 124 (def-vm-support-routine make-call-out-tns (type)
 125   (let ((arg-state (make-arg-state)))
 126     (collect ((arg-tns))
 127       (dolist #+nil ;; this reversed list seems to cause the alien botches!!
 128         (arg-type (reverse (alien-function-type-arg-types type)))
 129         (arg-type (alien-function-type-arg-types type))
 130         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 131       (values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset)
 132               (* (arg-state-stack-frame-size arg-state) word-bytes)
 133               (arg-tns)
 134               (invoke-alien-type-method :result-tn
 135                                         (alien-function-type-result-type type)
 136                                         (make-result-state))))))
 137
 138 (define-vop (foreign-symbol-address)
 139   (:translate foreign-symbol-address)
 140   (:policy :fast-safe)
 141   (:args)
 142   (:arg-types (:constant simple-string))
 143   (:info foreign-symbol)
 144   (:results (res :scs (sap-reg)))
 145   (:result-types system-area-pointer)
 146   (:generator 2
 147    (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
 148
 149 (define-vop (call-out)
 150   (:args (function :scs (sap-reg))
 151          (args :more t))
 152   (:results (results :more t))
 153   ;; eax is already wired
 154   (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 155   (:temporary (:sc unsigned-reg :offset edx-offset) edx)
 156   (:node-var node)
 157   (:vop-var vop)
 158   (:save-p t)
 159   (:ignore args ecx edx)
 160   (:generator 0
 161     (cond ((policy node (> space speed))
 162            (move eax-tn function)
 163            (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)))
 164           (t
 165            ;; Setup the NPX for C; all the FP registers need to be
 166            ;; empty; pop them all.
 167            (inst fstp fr0-tn)
 168            (inst fstp fr0-tn)
 169            (inst fstp fr0-tn)
 170            (inst fstp fr0-tn)
 171            (inst fstp fr0-tn)
 172            (inst fstp fr0-tn)
 173            (inst fstp fr0-tn)
 174            (inst fstp fr0-tn)
 175
 176            (inst call function)
 177            ;; To give the debugger a clue. XX not really internal-error?
 178            (note-this-location vop :internal-error)
 179
 180            ;; Restore the NPX for lisp.
 181            (inst fldz) ; insure no regs are empty
 182            (inst fldz)
 183            (inst fldz)
 184            (inst fldz)
 185            (inst fldz)
 186            (inst fldz)
 187            (inst fldz)
 188
 189            (if (and results
 190                     (location= (tn-ref-tn results) fr0-tn))
 191                ;; The return result is in fr0.
 192                (inst fxch fr7-tn) ; move the result back to fr0
 193                (inst fldz)) ; insure no regs are empty
 194            ))))
 195
 196 (define-vop (alloc-number-stack-space)
 197   (:info amount)
 198   (:results (result :scs (sap-reg any-reg)))
 199   (:generator 0
 200     (assert (location= result esp-tn))
 201     (unless (zerop amount)
 202       (let ((delta (logandc2 (+ amount 3) 3)))
 203         (inst sub esp-tn delta)))
 204     (move result esp-tn)))
 205
 206 (define-vop (dealloc-number-stack-space)
 207   (:info amount)
 208   (:generator 0
 209     (unless (zerop amount)
 210       (let ((delta (logandc2 (+ amount 3) 3)))
 211         (inst add esp-tn delta)))))
 212
 213 (define-vop (alloc-alien-stack-space)
 214   (:info amount)
 215   (:results (result :scs (sap-reg any-reg)))
 216   (:generator 0
 217     (assert (not (location= result esp-tn)))
 218     (unless (zerop amount)
 219       (let ((delta (logandc2 (+ amount 3) 3)))
 220         (inst sub (make-ea :dword
 221                            :disp (+ nil-value
 222                                     (static-symbol-offset '*alien-stack*)
 223                                     (ash symbol-value-slot word-shift)
 224                                     (- other-pointer-type)))
 225               delta)))
 226     (load-symbol-value result *alien-stack*)))
 227
 228 (define-vop (dealloc-alien-stack-space)
 229   (:info amount)
 230   (:generator 0
 231     (unless (zerop amount)
 232       (let ((delta (logandc2 (+ amount 3) 3)))
 233         (inst add (make-ea :dword
 234                            :disp (+ nil-value
 235                                     (static-symbol-offset '*alien-stack*)
 236                                     (ash symbol-value-slot word-shift)
 237                                     (- other-pointer-type)))
 238               delta)))))