src/compiler/x86-64/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 ;; The MOVE-ARG vop is going to store args on the stack for
  16 ;; call-out. These tn's will be used for that. move-arg is normally
  17 ;; used for things going down the stack but C wants to have args
  18 ;; indexed in the positive direction.
  19
  20 (defun my-make-wired-tn (prim-type-name sc-name offset)
  21   (make-wired-tn (primitive-type-or-lose prim-type-name)
  22                  (sc-number-or-lose sc-name)
  23                  offset))
  24
  25 (defstruct (arg-state (:copier nil))
  26   (register-args 0)
  27   (xmm-args 0)
  28   (stack-frame-size 0))
  29
  30 (defun int-arg (state prim-type reg-sc stack-sc)
  31   (let ((reg-args (arg-state-register-args state)))
  32     (cond ((< reg-args 6)
  33            (setf (arg-state-register-args state) (1+ reg-args))
  34            (my-make-wired-tn prim-type reg-sc
  35                              (nth reg-args *c-call-register-arg-offsets*)))
  36           (t
  37            (let ((frame-size (arg-state-stack-frame-size state)))
  38              (setf (arg-state-stack-frame-size state) (1+ frame-size))
  39              (my-make-wired-tn prim-type stack-sc frame-size))))))
  40
  41 (define-alien-type-method (integer :arg-tn) (type state)
  42   (if (alien-integer-type-signed type)
  43       (int-arg state 'signed-byte-64 'signed-reg 'signed-stack)
  44       (int-arg state 'unsigned-byte-64 'unsigned-reg 'unsigned-stack)))
  45
  46 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
  47   (declare (ignore type))
  48   (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
  49
  50 (defun float-arg (state prim-type reg-sc stack-sc)
  51   (let ((xmm-args (arg-state-xmm-args state)))
  52     (cond ((< xmm-args 8)
  53            (setf (arg-state-xmm-args state) (1+ xmm-args))
  54            (my-make-wired-tn prim-type reg-sc
  55                              (nth xmm-args *float-regs*)))
  56           (t
  57            (let ((frame-size (arg-state-stack-frame-size state)))
  58              (setf (arg-state-stack-frame-size state) (1+ frame-size))
  59              (my-make-wired-tn prim-type stack-sc frame-size))))))
  60
  61 (define-alien-type-method (double-float :arg-tn) (type state)
  62   (declare (ignore type))
  63   (float-arg state 'double-float 'double-reg 'double-stack))
  64
  65 (define-alien-type-method (single-float :arg-tn) (type state)
  66   (declare (ignore type))
  67   (float-arg state 'single-float 'single-reg 'single-stack))
  68
  69 (defstruct (result-state (:copier nil))
  70   (num-results 0))
  71
  72 (defun result-reg-offset (slot)
  73   (ecase slot
  74     (0 eax-offset)
  75     (1 edx-offset)))
  76
  77 ;; XXX The return handling probably doesn't conform to the ABI
  78
  79 (define-alien-type-method (integer :result-tn) (type state)
  80   (let ((num-results (result-state-num-results state)))
  81     (setf (result-state-num-results state) (1+ num-results))
  82     (multiple-value-bind (ptype reg-sc)
  83         (if (alien-integer-type-signed type)
  84             (values (if (= (sb!alien::alien-integer-type-bits type) 32)
  85                         'signed-byte-32
  86                         'signed-byte-64)
  87                     'signed-reg)
  88             (values 'unsigned-byte-64 'unsigned-reg))
  89       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
  90
  91 (define-alien-type-method (system-area-pointer :result-tn) (type state)
  92   (declare (ignore type))
  93   (let ((num-results (result-state-num-results state)))
  94     (setf (result-state-num-results state) (1+ num-results))
  95     (my-make-wired-tn 'system-area-pointer 'sap-reg
  96                       (result-reg-offset num-results))))
  97
  98 (define-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)))
 103
 104 (define-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 (define-alien-type-method (values :result-tn) (type state)
 111   (let ((values (alien-values-type-values type)))
 112     (when (> (length values) 2)
 113       (error "Too many result values from c-call."))
 114     (mapcar (lambda (type)
 115               (invoke-alien-type-method :result-tn type state))
 116             values)))
 117
 118 (!def-vm-support-routine make-call-out-tns (type)
 119   (let ((arg-state (make-arg-state)))
 120     (collect ((arg-tns))
 121       (dolist (arg-type (alien-fun-type-arg-types type))
 122         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
 123       (values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset)
 124               (* (arg-state-stack-frame-size arg-state) n-word-bytes)
 125               (arg-tns)
 126               (invoke-alien-type-method :result-tn
 127                                         (alien-fun-type-result-type type)
 128                                         (make-result-state))))))
 129
 130
 131 (deftransform %alien-funcall ((function type &rest args) * * :node node)
 132   (aver (sb!c::constant-lvar-p type))
 133   (let* ((type (sb!c::lvar-value type))
 134          (env (sb!c::node-lexenv node))
 135          (arg-types (alien-fun-type-arg-types type))
 136          (result-type (alien-fun-type-result-type type)))
 137     (aver (= (length arg-types) (length args)))
 138     (if (or (some #'(lambda (type)
 139                       (and (alien-integer-type-p type)
 140                            (> (sb!alien::alien-integer-type-bits type) 64)))
 141                   arg-types)
 142             (and (alien-integer-type-p result-type)
 143                  (> (sb!alien::alien-integer-type-bits result-type) 64)))
 144         (collect ((new-args) (lambda-vars) (new-arg-types))
 145           (dolist (type arg-types)
 146             (let ((arg (gensym)))
 147               (lambda-vars arg)
 148               (cond ((and (alien-integer-type-p type)
 149                           (> (sb!alien::alien-integer-type-bits type) 64))
 150                      (new-args `(logand ,arg #xffffffff))
 151                      (new-args `(ash ,arg -64))
 152                      (new-arg-types (parse-alien-type '(unsigned 64) env))
 153                      (if (alien-integer-type-signed type)
 154                          (new-arg-types (parse-alien-type '(signed 64) env))
 155                          (new-arg-types (parse-alien-type '(unsigned 64) env))))
 156                     (t
 157                      (new-args arg)
 158                      (new-arg-types type)))))
 159           (cond ((and (alien-integer-type-p result-type)
 160                       (> (sb!alien::alien-integer-type-bits result-type) 64))
 161                  (let ((new-result-type
 162                         (let ((sb!alien::*values-type-okay* t))
 163                           (parse-alien-type
 164                            (if (alien-integer-type-signed result-type)
 165                                '(values (unsigned 64) (signed 64))
 166                                '(values (unsigned 64) (unsigned 64)))
 167                            env))))
 168                    `(lambda (function type ,@(lambda-vars))
 169                       (declare (ignore type))
 170                       (multiple-value-bind (low high)
 171                           (%alien-funcall function
 172                                           ',(make-alien-fun-type
 173                                              :arg-types (new-arg-types)
 174                                              :result-type new-result-type)
 175                                           ,@(new-args))
 176                         (logior low (ash high 64))))))
 177                 (t
 178                  `(lambda (function type ,@(lambda-vars))
 179                     (declare (ignore type))
 180                     (%alien-funcall function
 181                                     ',(make-alien-fun-type
 182                                        :arg-types (new-arg-types)
 183                                        :result-type result-type)
 184                                     ,@(new-args))))))
 185         (sb!c::give-up-ir1-transform))))
 186
 187
 188
 189
 190 (define-vop (foreign-symbol-address)
 191   (:translate foreign-symbol-address)
 192   (:policy :fast-safe)
 193   (:args)
 194   (:arg-types (:constant simple-string))
 195   (:info foreign-symbol)
 196   (:results (res :scs (sap-reg)))
 197   (:result-types system-area-pointer)
 198   (:generator 2
 199    (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
 200
 201 #!+linkage-table
 202 (define-vop (foreign-symbol-dataref-address)
 203   (:translate foreign-symbol-dataref-address)
 204   (:policy :fast-safe)
 205   (:args)
 206   (:arg-types (:constant simple-string))
 207   (:info foreign-symbol)
 208   (:results (res :scs (sap-reg)))
 209   (:result-types system-area-pointer)
 210   (:generator 2
 211    (inst mov res (make-fixup (extern-alien-name foreign-symbol) :foreign-dataref))))
 212
 213 (define-vop (call-out)
 214   (:args (function :scs (sap-reg))
 215          (args :more t))
 216   (:results (results :more t))
 217   (:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax)
 218   (:temporary (:sc unsigned-reg :offset rcx-offset
 219                    :from :eval :to :result) rcx)
 220   (:vop-var vop)
 221   (:save-p t)
 222   (:generator 0
 223     ;; ABI: AL contains amount of arguments passed in XMM registers
 224     ;; for vararg calls.
 225     (move-immediate rax
 226                     (loop for tn-ref = args then (tn-ref-across tn-ref)
 227                        while tn-ref
 228                        count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref))))
 229                                  'float-registers)))
 230     (inst call function)
 231     ;; To give the debugger a clue. XX not really internal-error?
 232     (note-this-location vop :internal-error)
 233     ;; Sign-extend s-b-32 return values.
 234     (dolist (res (if (listp results)
 235                      results
 236                      (list results)))
 237       (let ((tn (tn-ref-tn res)))
 238         (when (eq (sb!c::tn-primitive-type tn)
 239                   (primitive-type-or-lose 'signed-byte-32))
 240           (inst movsxd tn (make-random-tn :kind :normal
 241                                           :sc (sc-or-lose 'dword-reg)
 242                                           :offset (tn-offset tn))))))
 243     ;; FLOAT15 needs to contain FP zero in Lispland
 244     (inst xor rcx rcx)
 245     (inst movd (make-random-tn :kind :normal
 246                                :sc (sc-or-lose 'double-reg)
 247                                :offset float15-offset)
 248           rcx)))
 249
 250 (define-vop (alloc-number-stack-space)
 251   (:info amount)
 252   (:results (result :scs (sap-reg any-reg)))
 253   (:generator 0
 254     (aver (location= result rsp-tn))
 255     (unless (zerop amount)
 256       (let ((delta (logandc2 (+ amount 3) 3)))
 257         (inst sub rsp-tn delta)))
 258     (move result rsp-tn)))
 259
 260 (define-vop (dealloc-number-stack-space)
 261   (:info amount)
 262   (:generator 0
 263     (unless (zerop amount)
 264       (let ((delta (logandc2 (+ amount 3) 3)))
 265         (inst add rsp-tn delta)))))
 266
 267 (define-vop (alloc-alien-stack-space)
 268   (:info amount)
 269   #!+sb-thread (:temporary (:sc unsigned-reg) temp)
 270   (:results (result :scs (sap-reg any-reg)))
 271   #!+sb-thread
 272   (:generator 0
 273     (aver (not (location= result rsp-tn)))
 274     (unless (zerop amount)
 275       (let ((delta (logandc2 (+ amount 3) 3)))
 276         (inst mov temp
 277               (make-ea :dword
 278                        :disp (+ nil-value
 279                                 (static-symbol-offset '*alien-stack*)
 280                                 (ash symbol-tls-index-slot word-shift)
 281                                 (- other-pointer-lowtag))))
 282         (inst fs-segment-prefix)
 283         (inst sub (make-ea :dword :scale 1 :index temp) delta)))
 284     (load-tl-symbol-value result *alien-stack*))
 285   #!-sb-thread
 286   (:generator 0
 287     (aver (not (location= result rsp-tn)))
 288     (unless (zerop amount)
 289       (let ((delta (logandc2 (+ amount 3) 3)))
 290         (inst sub (make-ea :qword
 291                            :disp (+ nil-value
 292                                     (static-symbol-offset '*alien-stack*)
 293                                     (ash symbol-value-slot word-shift)
 294                                     (- other-pointer-lowtag)))
 295               delta)))
 296     (load-symbol-value result *alien-stack*)))
 297
 298 (define-vop (dealloc-alien-stack-space)
 299   (:info amount)
 300   #!+sb-thread (:temporary (:sc unsigned-reg) temp)
 301   #!+sb-thread
 302   (:generator 0
 303     (unless (zerop amount)
 304       (let ((delta (logandc2 (+ amount 3) 3)))
 305         (inst mov temp
 306               (make-ea :dword
 307                            :disp (+ nil-value
 308                                     (static-symbol-offset '*alien-stack*)
 309                                 (ash symbol-tls-index-slot word-shift)
 310                                 (- other-pointer-lowtag))))
 311         (inst fs-segment-prefix)
 312         (inst add (make-ea :dword :scale 1 :index temp) delta))))
 313   #!-sb-thread
 314   (:generator 0
 315     (unless (zerop amount)
 316       (let ((delta (logandc2 (+ amount 3) 3)))
 317         (inst add (make-ea :qword
 318                            :disp (+ nil-value
 319                                     (static-symbol-offset '*alien-stack*)
 320                                     (ash symbol-value-slot word-shift)
 321                                     (- other-pointer-lowtag)))
 322               delta)))))
 323
 324 ;;; these are not strictly part of the c-call convention, but are
 325 ;;; needed for the WITH-PRESERVED-POINTERS macro used for "locking
 326 ;;; down" lisp objects so that GC won't move them while foreign
 327 ;;; functions go to work.
 328
 329 (define-vop (push-word-on-c-stack)
 330     (:translate push-word-on-c-stack)
 331   (:args (val :scs (sap-reg)))
 332   (:policy :fast-safe)
 333   (:arg-types system-area-pointer)
 334   (:generator 2
 335     (inst push val)))
 336
 337 (define-vop (pop-words-from-c-stack)
 338     (:translate pop-words-from-c-stack)
 339   (:args)
 340   (:arg-types (:constant (unsigned-byte 60)))
 341   (:info number)
 342   (:policy :fast-safe)
 343   (:generator 2
 344     (inst add rsp-tn (fixnumize number))))
 345