0420526f671f6345c3c86863e483ba363e0f7eaa
[sbcl.git] / 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 'signed-byte-64 'signed-reg)
85             (values 'unsigned-byte-64 'unsigned-reg))
86       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
87
88 (define-alien-type-method (integer :naturalize-gen) (type alien)
89   (if (and (alien-integer-type-signed type)
90            (<= (alien-type-bits type) 32))
91       `(sign-extend ,alien)
92       alien))
93
94 (define-alien-type-method (system-area-pointer :result-tn) (type state)
95   (declare (ignore type))
96   (let ((num-results (result-state-num-results state)))
97     (setf (result-state-num-results state) (1+ num-results))
98     (my-make-wired-tn 'system-area-pointer 'sap-reg
99                       (result-reg-offset num-results))))
100
101 (define-alien-type-method (double-float :result-tn) (type state)
102   (declare (ignore type))
103   (let ((num-results (result-state-num-results state)))
104     (setf (result-state-num-results state) (1+ num-results))
105     (my-make-wired-tn 'double-float 'double-reg num-results)))
106
107 (define-alien-type-method (single-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 'single-float 'single-reg num-results)))
112
113 (define-alien-type-method (values :result-tn) (type state)
114   (let ((values (alien-values-type-values type)))
115     (when (> (length values) 2)
116       (error "Too many result values from c-call."))
117     (mapcar (lambda (type)
118               (invoke-alien-type-method :result-tn type state))
119             values)))
120
121 (!def-vm-support-routine make-call-out-tns (type)
122   (let ((arg-state (make-arg-state)))
123     (collect ((arg-tns))
124       (dolist (arg-type (alien-fun-type-arg-types type))
125         (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
126       (values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset)
127               (* (arg-state-stack-frame-size arg-state) n-word-bytes)
128               (arg-tns)
129               (invoke-alien-type-method :result-tn
130                                         (alien-fun-type-result-type type)
131                                         (make-result-state))))))
132
133
134 (deftransform %alien-funcall ((function type &rest args) * * :node node)
135   (aver (sb!c::constant-lvar-p type))
136   (let* ((type (sb!c::lvar-value type))
137          (env (sb!c::node-lexenv node))
138          (arg-types (alien-fun-type-arg-types type))
139          (result-type (alien-fun-type-result-type type)))
140     (aver (= (length arg-types) (length args)))
141     (if (or (some #'(lambda (type)
142                       (and (alien-integer-type-p type)
143                            (> (sb!alien::alien-integer-type-bits type) 64)))
144                   arg-types)
145             (and (alien-integer-type-p result-type)
146                  (> (sb!alien::alien-integer-type-bits result-type) 64)))
147         (collect ((new-args) (lambda-vars) (new-arg-types))
148           (dolist (type arg-types)
149             (let ((arg (gensym)))
150               (lambda-vars arg)
151               (cond ((and (alien-integer-type-p type)
152                           (> (sb!alien::alien-integer-type-bits type) 64))
153                      (new-args `(logand ,arg #xffffffff))
154                      (new-args `(ash ,arg -64))
155                      (new-arg-types (parse-alien-type '(unsigned 64) env))
156                      (if (alien-integer-type-signed type)
157                          (new-arg-types (parse-alien-type '(signed 64) env))
158                          (new-arg-types (parse-alien-type '(unsigned 64) env))))
159                     (t
160                      (new-args arg)
161                      (new-arg-types type)))))
162           (cond ((and (alien-integer-type-p result-type)
163                       (> (sb!alien::alien-integer-type-bits result-type) 64))
164                  (let ((new-result-type
165                         (let ((sb!alien::*values-type-okay* t))
166                           (parse-alien-type
167                            (if (alien-integer-type-signed result-type)
168                                '(values (unsigned 64) (signed 64))
169                                '(values (unsigned 64) (unsigned 64)))
170                            env))))
171                    `(lambda (function type ,@(lambda-vars))
172                       (declare (ignore type))
173                       (multiple-value-bind (low high)
174                           (%alien-funcall function
175                                           ',(make-alien-fun-type
176                                              :arg-types (new-arg-types)
177                                              :result-type new-result-type)
178                                           ,@(new-args))
179                         (logior low (ash high 64))))))
180                 (t
181                  `(lambda (function type ,@(lambda-vars))
182                     (declare (ignore type))
183                     (%alien-funcall function
184                                     ',(make-alien-fun-type
185                                        :arg-types (new-arg-types)
186                                        :result-type result-type)
187                                     ,@(new-args))))))
188         (sb!c::give-up-ir1-transform))))
189
190 ;;; The ABI specifies that signed short/int's are returned as 32-bit
191 ;;; values. Negative values need to be sign-extended to 64-bits (done
192 ;;; in a :NATURALIZE-GEN alien-type-method).
193 (defknown sign-extend ((signed-byte 64)) (signed-byte 64)
194           (foldable flushable movable))
195
196 (define-vop (sign-extend)
197   (:translate sign-extend)
198   (:policy :fast-safe)
199   (:args (val :scs (signed-reg)))
200   (:arg-types signed-byte-64)
201   (:results (res :scs (signed-reg)))
202   (:result-types signed-byte-64)
203   (:generator 1
204    (inst movsxd res
205          (make-random-tn :kind :normal
206                          :sc (sc-or-lose 'dword-reg)
207                          :offset (tn-offset val)))))
208
209 (defun sign-extend (x)
210   (if (logbitp 31 x)
211       (dpb x (byte 32 0) -1)
212       (ldb (byte 32 0) x)))
213
214 (define-vop (foreign-symbol-sap)
215   (:translate foreign-symbol-sap)
216   (:policy :fast-safe)
217   (:args)
218   (:arg-types (:constant simple-string))
219   (:info foreign-symbol)
220   (:results (res :scs (sap-reg)))
221   (:result-types system-area-pointer)
222   (:generator 2
223    (inst lea res (make-fixup foreign-symbol :foreign))))
224
225 #!+linkage-table
226 (define-vop (foreign-symbol-dataref-sap)
227   (:translate foreign-symbol-dataref-sap)
228   (:policy :fast-safe)
229   (:args)
230   (:arg-types (:constant simple-string))
231   (:info foreign-symbol)
232   (:results (res :scs (sap-reg)))
233   (:result-types system-area-pointer)
234   (:generator 2
235    (inst mov res (make-fixup foreign-symbol :foreign-dataref))))
236
237 (define-vop (call-out)
238   (:args (function :scs (sap-reg))
239          (args :more t))
240   (:results (results :more t))
241   (:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax)
242   (:ignore results)
243   (:vop-var vop)
244   (:save-p t)
245   (:generator 0
246     ;; ABI: AL contains amount of arguments passed in XMM registers
247     ;; for vararg calls.
248     (move-immediate rax
249                     (loop for tn-ref = args then (tn-ref-across tn-ref)
250                        while tn-ref
251                        count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref))))
252                                  'float-registers)))
253     (inst call function)
254     ;; To give the debugger a clue. XX not really internal-error?
255     (note-this-location vop :internal-error)))
256
257 (define-vop (alloc-number-stack-space)
258   (:info amount)
259   (:results (result :scs (sap-reg any-reg)))
260   (:generator 0
261     (aver (location= result rsp-tn))
262     (unless (zerop amount)
263       (let ((delta (logandc2 (+ amount 7) 7)))
264         (inst sub rsp-tn delta)))
265     ;; C stack must be 16 byte aligned
266     (inst and rsp-tn -16)
267     (move result rsp-tn)))
268
269 (define-vop (dealloc-number-stack-space)
270   (:info amount)
271   (:generator 0
272     (unless (zerop amount)
273       (let ((delta (logandc2 (+ amount 7) 7)))
274         (inst add rsp-tn delta)))))
275
276 (define-vop (alloc-alien-stack-space)
277   (:info amount)
278   #!+sb-thread (:temporary (:sc unsigned-reg) temp)
279   (:results (result :scs (sap-reg any-reg)))
280   #!+sb-thread
281   (:generator 0
282     (aver (not (location= result rsp-tn)))
283     (unless (zerop amount)
284       (let ((delta (logandc2 (+ amount 7) 7)))
285         (inst mov temp
286               (make-ea :qword
287                        :disp (+ nil-value
288                                 (static-symbol-offset '*alien-stack*)
289                                 (ash symbol-tls-index-slot word-shift)
290                                 (- other-pointer-lowtag))))
291         (inst sub (make-ea :qword :base thread-base-tn
292                            :scale 1 :index temp) delta)))
293     (load-tl-symbol-value result *alien-stack*))
294   #!-sb-thread
295   (:generator 0
296     (aver (not (location= result rsp-tn)))
297     (unless (zerop amount)
298       (let ((delta (logandc2 (+ amount 7) 7)))
299         (inst sub (make-ea :qword
300                            :disp (+ nil-value
301                                     (static-symbol-offset '*alien-stack*)
302                                     (ash symbol-value-slot word-shift)
303                                     (- other-pointer-lowtag)))
304               delta)))
305     (load-symbol-value result *alien-stack*)))
306
307 (define-vop (dealloc-alien-stack-space)
308   (:info amount)
309   #!+sb-thread (:temporary (:sc unsigned-reg) temp)
310   #!+sb-thread
311   (:generator 0
312     (unless (zerop amount)
313       (let ((delta (logandc2 (+ amount 7) 7)))
314         (inst mov temp
315               (make-ea :qword
316                        :disp (+ nil-value
317                                 (static-symbol-offset '*alien-stack*)
318                                 (ash symbol-tls-index-slot word-shift)
319                                 (- other-pointer-lowtag))))
320         (inst add (make-ea :qword :base thread-base-tn :scale 1 :index temp)
321               delta))))
322   #!-sb-thread
323   (:generator 0
324     (unless (zerop amount)
325       (let ((delta (logandc2 (+ amount 7) 7)))
326         (inst add (make-ea :qword
327                            :disp (+ nil-value
328                                     (static-symbol-offset '*alien-stack*)
329                                     (ash symbol-value-slot word-shift)
330                                     (- other-pointer-lowtag)))
331               delta)))))
332
333 ;;; these are not strictly part of the c-call convention, but are
334 ;;; needed for the WITH-PRESERVED-POINTERS macro used for "locking
335 ;;; down" lisp objects so that GC won't move them while foreign
336 ;;; functions go to work.
337
338 (define-vop (push-word-on-c-stack)
339     (:translate push-word-on-c-stack)
340   (:args (val :scs (sap-reg)))
341   (:policy :fast-safe)
342   (:arg-types system-area-pointer)
343   (:generator 2
344     (inst push val)))
345
346 (define-vop (pop-words-from-c-stack)
347     (:translate pop-words-from-c-stack)
348   (:args)
349   (:arg-types (:constant (unsigned-byte 60)))
350   (:info number)
351   (:policy :fast-safe)
352   (:generator 2
353     (inst add rsp-tn (fixnumize number))))
354
355 ;;; Callbacks
356
357 #-sb-xc-host
358 (defun alien-callback-accessor-form (type sp offset)
359   `(deref (sap-alien (sap+ ,sp ,offset) (* ,type))))
360
361 #-sb-xc-host
362 (defun alien-callback-assembler-wrapper (index result-type argument-types)
363   (labels ((make-tn-maker (sc-name)
364              (lambda (offset)
365                (make-random-tn :kind :normal
366                                :sc (sc-or-lose sc-name)
367                                :offset offset)))
368            (out-of-registers-error ()
369              (error "Too many arguments in callback")))
370     (let* ((segment (make-segment))
371            (rax rax-tn)
372            (rcx rcx-tn)
373            (rdi rdi-tn)
374            (rsi rsi-tn)
375            (rdx rdx-tn)
376            (rbp rbp-tn)
377            (rsp rsp-tn)
378            (xmm0 float0-tn)
379            ([rsp] (make-ea :qword :base rsp :disp 0))
380            (words-processed 0)
381            (gprs (mapcar (make-tn-maker 'any-reg) *c-call-register-arg-offsets*))
382            (fprs (mapcar (make-tn-maker 'double-reg)
383                          ;; Only 8 first XMM registers are used for
384                          ;; passing arguments
385                          (subseq *float-regs* 0 8))))
386       (assemble (segment)
387         ;; Make room on the stack for arguments.
388         (inst sub rsp (* n-word-bytes (length argument-types)))
389         ;; Copy arguments from registers to stack
390         (dolist (type argument-types)
391           (let ((integerp (not (alien-float-type-p type)))
392                 (stack-tn (make-ea :qword :base rsp
393                                    :disp (* words-processed
394                                             n-word-bytes))))
395             (incf words-processed)
396             (cond (integerp
397                    (let ((gpr (pop gprs)))
398                      (if gpr
399                          (inst mov stack-tn gpr)
400                          (out-of-registers-error))))
401                   ((or (alien-single-float-type-p type)
402                        (alien-double-float-type-p type))
403                    (let ((fpr (pop fprs)))
404                      (if fpr
405                          (inst movq stack-tn fpr)
406                          (out-of-registers-error))))
407                   (t
408                    (bug "Unknown alien floating point type: ~S" type)))))
409
410         ;; arg0 to FUNCALL3 (function)
411         ;;
412         ;; Indirect the access to ENTER-ALIEN-CALLBACK through
413         ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
414         ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
415         ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone
416         ;; to rebind the variable. -- JES, 2006-01-01
417         (inst mov rdi (+ nil-value (static-symbol-offset
418                                     'sb!alien::*enter-alien-callback*)))
419         (loadw rdi rdi symbol-value-slot other-pointer-lowtag)
420         ;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index)
421         (inst mov rsi (fixnumize index))
422         ;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)
423         (inst mov rdx rsp)
424         ;; add room on stack for return value
425         (inst sub rsp 8)
426         ;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value)
427         (inst mov rcx rsp)
428
429         ;; Make new frame
430         (inst push rbp)
431         (inst mov  rbp rsp)
432
433         ;; Call
434         (inst mov  rax (foreign-symbol-address "funcall3"))
435         (inst call rax)
436
437         ;; Back! Restore frame
438         (inst mov rsp rbp)
439         (inst pop rbp)
440
441         ;; Result now on top of stack, put it in the right register
442         (cond
443           ((or (alien-integer-type-p result-type)
444                (alien-pointer-type-p result-type)
445                (alien-type-= #.(parse-alien-type 'system-area-pointer nil)
446                              result-type))
447            (inst mov rax [rsp]))
448           ((or (alien-single-float-type-p result-type)
449                (alien-double-float-type-p result-type))
450            (inst movq xmm0 [rsp]))
451           ((alien-void-type-p result-type))
452           (t
453            (error "unrecognized alien type: ~A" result-type)))
454
455         ;; Pop the arguments and the return value from the stack to get
456         ;; the return address at top of stack.
457         (inst add rsp (* (1+ (length argument-types)) n-word-bytes))
458         ;; Return
459         (inst ret))
460       (finalize-segment segment)
461       ;; Now that the segment is done, convert it to a static
462       ;; vector we can point foreign code to.
463       (let ((buffer (sb!assem::segment-buffer segment)))
464         (make-static-vector (length buffer)
465                             :element-type '(unsigned-byte 8)
466                             :initial-contents buffer)))))