source: branches/win64/compiler/X86/X8664/x8664-backend.lisp @ 8642

Last change on this file since 8642 was 8642, checked in by gb, 12 years ago

Define a WIN64 backend, ftd info for it. Set its LISP-CONTEXT-REGISTER
to r11/save3, since there doesn't seem to be a way to steal a segment
register on win64.
win64 ftd defines :bits-per-long as 32, to try to persuade things that
"signed/unsigned long" is 32 bits wide on win64.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.1 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2005 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18(eval-when (:compile-toplevel :load-toplevel :execute)
19  (require "BACKEND"))
20
21(eval-when (:compile-toplevel :execute)
22  (require "NXENV")
23  (require "X8664ENV"))
24
25
26(defvar *x8664-vinsn-templates* (make-hash-table :test #'eq))
27
28
29
30(defvar *known-x8664-backends* ())
31
32
33#+(or linuxx86-target (not x86-target))
34(defvar *linuxx8664-backend*
35  (make-backend :lookup-opcode 'lookup-x86-opcode
36                :lookup-macro #'false
37                :lap-opcodes x86::*x8664-opcode-templates*
38                :define-vinsn 'define-x86-vinsn
39                :platform-syscall-mask (logior platform-os-linux platform-cpu-x86 platform-word-size-64) 
40                :p2-dispatch *x862-specials*
41                :p2-vinsn-templates *x8664-vinsn-templates*
42                :p2-template-hash-name '*x8664-vinsn-templates*
43                :p2-compile 'x862-compile
44                :target-specific-features
45                '(:x8664 :x86-target :linux-target :linuxx86-target :x8664-target
46                  :linuxx8664-target
47                  :little-endian-target
48                  :64-bit-target)
49                :target-fasl-pathname (make-pathname :type "lx64fsl")
50                :target-platform (logior platform-cpu-x86
51                                         platform-os-linux
52                                         platform-word-size-64)
53                :target-os :linuxx86
54                :name :linuxx8664
55                :target-arch-name :x8664
56                :target-foreign-type-data nil
57
58
59                :target-arch x8664::*x8664-target-arch*
60                :lisp-context-register x8664::gs
61                ))
62
63
64#+darwinx86-target
65(defvar *darwinx8664-backend*
66  (make-backend :lookup-opcode 'lookup-x86-opcode
67                :lookup-macro #'false
68                :lap-opcodes x86::*x8664-opcode-templates*
69                :define-vinsn 'define-x86-vinsn
70                :p2-dispatch *x862-specials*
71                :p2-vinsn-templates *x8664-vinsn-templates*
72                :p2-template-hash-name '*x8664-vinsn-templates*
73                :p2-compile 'x862-compile
74                :platform-syscall-mask (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) 
75                :target-specific-features
76                '(:x8664 :x86-target :darwin-target :darwinx86-target :x8664-target
77                  :darwinx8664-target
78                  :little-endian-target
79                  :64-bit-target)
80                :target-fasl-pathname (make-pathname :type "dx64fsl")
81                :target-platform (logior platform-cpu-x86
82                                         platform-os-darwin
83                                         platform-word-size-64)
84                :target-os :darwinx86
85                :name :darwinx8664
86                :target-arch-name :x8664
87                :target-foreign-type-data nil
88                :target-arch x8664::*x8664-target-arch*
89                ;; Overload %gs until Apple straightens things out.
90                :lisp-context-register x8664::gs
91                ))
92
93#+freebsdx86-target
94(defvar *freebsdx8664-backend*
95  (make-backend :lookup-opcode 'lookup-x86-opcode
96                :lookup-macro #'false
97                :lap-opcodes x86::*x8664-opcode-templates*
98                :define-vinsn 'define-x86-vinsn
99                :p2-dispatch *x862-specials*
100                :p2-vinsn-templates *x8664-vinsn-templates*
101                :p2-template-hash-name '*x8664-vinsn-templates*
102                :p2-compile 'x862-compile
103                :target-specific-features
104                '(:x8664 :x86-target :freebsd-target :freebsdx86-target :x8664-target
105                  :freebsdx8664-target                 
106                  :little-endian-target
107                  :64-bit-target)
108                :target-fasl-pathname (make-pathname :type "fx64fsl")
109                :target-platform (logior platform-cpu-x86
110                                         platform-os-freebsd
111                                         platform-word-size-64)
112                :target-os :freebsdx86
113                :name :freebsdx8664
114                :target-arch-name :x8664
115                :target-foreign-type-data nil
116                :target-arch x8664::*x8664-target-arch*
117                :platform-syscall-mask (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)
118                :lisp-context-register x8664::gs
119                ))
120
121#+win64-target
122(defvar *win64-backend*
123  (make-backend :lookup-opcode 'lookup-x86-opcode
124                :lookup-macro #'false
125                :lap-opcodes x86::*x8664-opcode-templates*
126                :define-vinsn 'define-x86-vinsn
127                :p2-dispatch *x862-specials*
128                :p2-vinsn-templates *x8664-vinsn-templates*
129                :p2-template-hash-name '*x8664-vinsn-templates*
130                :p2-compile 'x862-compile
131                :target-specific-features
132                '(:x8664 :x86-target :win64-target :windows-target :x8664-target
133                  :winx64-target                 
134                  :little-endian-target
135                  :64-bit-target)
136                :target-fasl-pathname (make-pathname :type "wx64fsl")
137                :target-platform (logior platform-cpu-x86
138                                         platform-os-windows
139                                         platform-word-size-64)
140                :target-os :win64
141                :name :win64
142                :target-arch-name :x8664
143                :target-foreign-type-data nil
144                :target-arch x8664::*x8664-target-arch*
145                :platform-syscall-mask (logior platform-os-windows platform-cpu-x86 platform-word-size-64)
146                :lisp-context-register x8664::r11
147                ))
148
149#+(or linuxx86-target (not x86-target))
150(pushnew *linuxx8664-backend* *known-x8664-backends* :key #'backend-name)
151
152
153#+darwinx86-target
154(pushnew *darwinx8664-backend* *known-x8664-backends* :key #'backend-name)
155
156#+freebsdx86-target
157(pushnew *freebsdx8664-backend* *known-x8664-backends* :key #'backend-name)
158
159#+win64-target
160(pushnew *win64-backend* *known-x8664-backends* :key #'backend-name)
161
162(defvar *x8664-backend* (car *known-x8664-backends*))
163
164(defun fixup-x8664-backend ()
165  (dolist (b *known-x8664-backends*)
166    (setf #| (backend-lap-opcodes b) x86::*x86-opcodes* |#
167          (backend-p2-dispatch b) *x862-specials*
168          (backend-p2-vinsn-templates b)  *x8664-vinsn-templates*)
169    (or (backend-lap-macros b) (setf (backend-lap-macros b)
170                                     (make-hash-table :test #'equalp)))))
171
172
173
174(fixup-x8664-backend)
175
176#+x8664-target
177(setq *host-backend* *x8664-backend* *target-backend* *x8664-backend*)
178
179(defun setup-x8664-ftd (backend)
180  (or (backend-target-foreign-type-data backend)
181      (let* ((name (backend-name backend))
182             (ftd
183              (case name
184                (:linuxx8664
185                 (make-ftd :interface-db-directory
186                           (if (eq backend *host-backend*)
187                             "ccl:x86-headers64;"
188                             "ccl:cross-x86-headers64;")
189                           :interface-package-name "X86-LINUX64"
190                           :attributes '(:bits-per-word  64
191                                         :struct-by-value t)
192                           :ff-call-expand-function
193                           (intern "EXPAND-FF-CALL" "X86-LINUX64")
194                           :ff-call-struct-return-by-implicit-arg-function
195                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
196                                   "X86-LINUX64")
197                           :callback-bindings-function
198                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-LINUX64")
199                           :callback-return-value-function
200                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-LINUX64")))
201                (:darwinx8664
202                 (make-ftd :interface-db-directory
203                           (if (eq backend *host-backend*)
204                             "ccl:darwin-x86-headers64;"
205                             "ccl:cross-darwin-x86-headers64;")
206                           :interface-package-name "X86-DARWIN64"
207                           :attributes '(:bits-per-word  64
208                                         :signed-char t
209                                         :struct-by-value t
210                                         :prepend-underscore t)
211                           :ff-call-expand-function
212                           (intern "EXPAND-FF-CALL" "X86-DARWIN64")
213                           :ff-call-struct-return-by-implicit-arg-function
214                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
215                                   "X86-DARWIN64")
216                           :callback-bindings-function
217                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-DARWIN64")
218                           :callback-return-value-function
219                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-DARWIN64")))
220                (:freebsdx8664
221                 (make-ftd :interface-db-directory
222                           (if (eq backend *host-backend*)
223                             "ccl:freebsd-headers64;"
224                             "ccl:cross-freebsd-headers64;")
225                           :interface-package-name "X86-FREEBSD64"
226                           :attributes '(:bits-per-word  64
227                                         :struct-by-value t)
228                           :ff-call-expand-function
229                           (intern "EXPAND-FF-CALL" "X86-FREEBSD64")
230                           :ff-call-struct-return-by-implicit-arg-function
231                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
232                                   "X86-FREEBSD64")
233                           :callback-bindings-function
234                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-FREEBSD64")
235                           :callback-return-value-function
236                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-FREEBSD64")))
237                (:win64
238                 (make-ftd :interface-db-directory
239                           (if (eq backend *host-backend*)
240                             "ccl:win64-headers;"
241                             "ccl:cross-win64-headers;")
242                           :interface-package-name "WIN64"
243                           :attributes '(:bits-per-word  64
244                                         :struct-by-value t
245                                         :bits-per-long 32)
246                           :ff-call-expand-function
247                           (intern "EXPAND-FF-CALL" "WIN64")
248                           :ff-call-struct-return-by-implicit-arg-function
249                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
250                                   "WIN64")
251                           :callback-bindings-function
252                           (intern "GENERATE-CALLBACK-BINDINGS" "WIN64")
253                           :callback-return-value-function
254                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "WIN64"))))))
255        (install-standard-foreign-types ftd)
256        (use-interface-dir :libc ftd)
257        (setf (backend-target-foreign-type-data backend) ftd))))
258
259#-x8664-target
260(setup-x8664-ftd *x8664-backend*)
261
262(pushnew *x8664-backend* *known-backends* :key #'backend-name)
263
264;;; FFI stuff.  Seems to be shared by Darwin/Linux/FreeBSD.
265
266;;; A returned structure is passed as an invisible first argument if
267;;; it's more than 2 doublewords long or if it contains unaligned fields.
268;;; Not clear how the latter case can happen, so this just checks for
269;;; the first.
270(defun x8664::record-type-returns-structure-as-first-arg (rtype)
271  (when (and rtype
272             (not (typep rtype 'unsigned-byte))
273             (not (member rtype *foreign-representation-type-keywords*
274                          :test #'eq)))
275    (let* ((ftype (if (typep rtype 'foreign-type)
276                    rtype
277                    (parse-foreign-type rtype))))
278      (> (ensure-foreign-type-bits ftype) 128))))
279
280;;; On x8664, structures can be passed by value:
281;;;  a) in memory, if they're more than 128 bits in size or if there aren't
282;;;     enough of the right kind of register to pass them entirely in registers.
283;;;  b) as a series of 64-bit chunks, passed in GPRs if any component of the
284;;;     chunk is a non FLOAT or in FPRs otherwise.
285;;; Note that this means that a chunk consisting of two SINGLE-FLOATs would
286;;; be passed in the low 64 bit of an SSE (xmm) register.
287
288(defun x8664::field-is-of-class-integer (field)
289  ;; Return true if field is of "class" integer or if it's a record
290  ;; type of class integer.  (See the System V AMD64 ABI document for
291  ;; a convoluted definition of field "classes".)
292  (let* ((ftype (foreign-record-field-type field)))
293    (typecase ftype
294      ((or foreign-integer-type foreign-pointer-type) t)
295      (foreign-record-type (dolist (f (foreign-record-type-fields ftype))
296                             (when (x8664::field-is-of-class-integer f)
297                               (return t))))
298      (otherwise nil))))
299
300(defun x8664::classify-8byte (field-list bit-limit)
301  ;; CDR down the fields in FIELD-LIST until we find a field of class integer,
302  ;; hit the end of the list, or find a field whose offset is >= BIT-LIMIT.
303  ;; In the first case, return :INTEGER.  In other cases, return :FLOAT.
304  (dolist (field field-list :float)
305    (if (<= bit-limit (foreign-record-field-offset field))
306      (return :float)
307      (if (x8664::field-is-of-class-integer field)
308        (return :integer)))))
309
310;;; Return a first value :memory, :integer, or::float and a second
311;;; value of NIL, :integer, or :float according to how the structure
312;;; RTYPE should ideally be passed or returned.  Note that the caller
313;;; may decide to turn this to :memory if there aren't enough
314;;; available registers of the right class when passing an instance of
315;;; this structure type.
316(defun x8664::classify-record-type (rtype)
317  (let* ((nbits (ensure-foreign-type-bits rtype))
318         (fields (foreign-record-type-fields rtype)))
319    (cond ((> nbits 128) (values :memory nil))
320          ((<= nbits 64) (values (x8664::classify-8byte fields 64) nil))
321          (t (values (x8664::classify-8byte fields 64)
322               (do* ()
323                    ((>= (foreign-record-field-offset (car fields)) 64)
324                     (x8664::classify-8byte fields 128))
325                 (setq fields (cdr fields))))))))
326
327(defun x8664::struct-from-regbuf-values (r rtype regbuf)
328  (multiple-value-bind (first second)
329      (x8664::classify-record-type rtype)
330    (let* ((gpr-offset 0)
331           (fpr-offset 16))
332      ;; Do this 32 bits at a time, to avoid consing.
333      (collect ((forms))
334        (case first
335          (:integer (forms `(setf (%get-unsigned-long ,r 0)
336                             (%get-unsigned-long ,regbuf 0)))
337                    (forms `(setf (%get-unsigned-long ,r 4)
338                             (%get-unsigned-long ,regbuf 4)))
339                    (setq gpr-offset 8))
340          (:float (forms `(setf (%get-unsigned-long ,r 0)
341                             (%get-unsigned-long ,regbuf 16)))
342                  (forms `(setf (%get-unsigned-long ,r 4)
343                             (%get-unsigned-long ,regbuf 20)))
344                  (setf fpr-offset 24)))
345        (case second
346          (:integer (forms `(setf (%get-unsigned-long ,r 8)
347                             (%get-unsigned-long ,regbuf ,gpr-offset)))
348                    (forms `(setf (%get-unsigned-long ,r 12)
349                             (%get-unsigned-long ,regbuf ,(+ gpr-offset 4)))))
350          (:float (forms `(setf (%get-unsigned-long ,r 8)
351                             (%get-unsigned-long ,regbuf ,fpr-offset)))
352                  (forms `(setf (%get-unsigned-long ,r 12)
353                             (%get-unsigned-long ,regbuf ,(+ fpr-offset 4))))))
354        `(progn ,@(forms))))))
355
356(defun x8664::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
357  (let* ((result-type-spec (or (car (last args)) :void))
358         (regbuf nil)
359         (result-temp nil)
360         (result-form nil)
361         (struct-result-type nil)
362         (structure-arg-temp nil))
363    (multiple-value-bind (result-type error)
364        (ignore-errors (parse-foreign-type result-type-spec))
365      (if error
366        (setq result-type-spec :void result-type *void-foreign-type*)
367        (setq args (butlast args)))
368      (collect ((argforms))
369        (when (eq (car args) :monitor-exception-ports)
370          (argforms (pop args)))
371        (when (typep result-type 'foreign-record-type)
372          (setq result-form (pop args)
373                struct-result-type result-type
374                result-type *void-foreign-type*
375                result-type-spec :void)
376          (if (x8664::record-type-returns-structure-as-first-arg struct-result-type)
377            (progn
378              (argforms :address)
379              (argforms result-form))
380            (progn
381              (setq regbuf (gensym)
382                    result-temp (gensym))
383              (argforms :registers)
384              (argforms regbuf))))
385        (let* ((valform nil))
386                      (unless (evenp (length args))
387              (error "~s should be an even-length list of alternating foreign types and values" args))
388            (do* ((args args (cddr args))
389                  (remaining-gprs 6)
390                  (remaining-fprs 8))
391                 ((null args))
392              (let* ((arg-type-spec (car args))
393                     (arg-value-form (cadr args)))
394                (if (or (member arg-type-spec *foreign-representation-type-keywords*
395                                :test #'eq)
396                        (typep arg-type-spec 'unsigned-byte))
397                  (progn
398                    (if (or (eq arg-type-spec :double-float)
399                            (eq arg-type-spec :single-float))
400                      (decf remaining-fprs)
401                      (unless (typep arg-type-spec 'unsigned-byte)
402                        (decf remaining-gprs)))
403                    (argforms arg-type-spec)
404                    (argforms arg-value-form))
405                  (let* ((ftype (parse-foreign-type arg-type-spec)))
406                    (if (typep ftype 'foreign-record-type)
407                      (multiple-value-bind (first8 second8)
408                          (x8664::classify-record-type ftype)
409                        (let* ((gprs remaining-gprs)
410                               (fprs remaining-fprs))
411                          (case first8
412                            (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
413                            (:float (if (< (decf fprs) 0) (setq first8 :memory))))
414                          (case second8
415                            (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
416                            (:float (if (< (decf fprs) 0) (setq first8 :memory)))))
417                        (if (eq first8 :memory)
418                          (progn
419                            (argforms (ceiling (foreign-record-type-bits ftype) 64))
420                            (argforms arg-value-form))
421                          (progn
422                            (if second8
423                              (progn
424                                (unless structure-arg-temp
425                                  (setq structure-arg-temp (gensym)))
426                                (setq valform `(%setf-macptr ,structure-arg-temp ,arg-value-form)))
427                              (setq valform arg-value-form))
428                            (if (eq first8 :float)
429                              (progn
430                                (decf remaining-fprs)
431                                (argforms :double-float)
432                                (argforms `(%get-double-float ,valform 0)))
433                              (progn
434                                (decf remaining-gprs)
435                                (argforms :unsigned-doubleword)
436                                (argforms `(%%get-unsigned-longlong ,valform 0))))
437                            (when second8
438                              (setq valform structure-arg-temp)
439                              (if (eq second8 :float)
440                                (progn
441                                (decf remaining-fprs)
442                                (argforms :double-float)
443                                (argforms `(%get-double-float ,valform 8)))
444                              (progn
445                                (decf remaining-gprs)
446                                (argforms :unsigned-doubleword)
447                                (argforms `(%%get-unsigned-longlong ,valform 8))))))))
448                      (let* ((rtype (foreign-type-to-representation-type ftype)))
449                        (if (or (eq rtype :singlefloat) (eq rtype :double-float))
450                          (decf remaining-fprs)
451                          (decf remaining-gprs))
452                        (argforms rtype)
453                        (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
454            (argforms (foreign-type-to-representation-type result-type))
455            (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
456              (when structure-arg-temp
457                (setq call `(let* ((,structure-arg-temp (%null-ptr)))
458                             (declare (dynamic-extent ,structure-arg-temp)
459                                      (type macptr ,structure-arg-temp))
460                             ,call)))
461              (if regbuf
462                `(let* ((,result-temp (%null-ptr)))
463                  (declare (dynamic-extent ,result-temp)
464                           (type macptr ,result-temp))
465                  (%setf-macptr ,result-temp ,result-form)
466                  (%stack-block ((,regbuf (+ (* 2 8) (* 2 8))))
467                    ,call
468                    ,(x8664::struct-from-regbuf-values result-temp struct-result-type regbuf)))
469                call)))))))
470
471
472;;; Return 7 values:
473;;; A list of RLET bindings
474;;; A list of LET* bindings
475;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
476;;; A list of initializaton forms for (some) structure args
477;;; A FOREIGN-TYPE representing the "actual" return type.
478;;; A form which can be used to initialize FP-ARGS-PTR, relative
479;;;  to STACK-PTR.  (This is unused on linuxppc32.)
480;;; The byte offset of the foreign return address, relative to STACK-PTR
481
482(defun x8664::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
483  (declare (ignore fp-args-ptr))
484  (collect ((lets)
485            (rlets)
486            (inits)
487            (dynamic-extent-names))
488    (let* ((rtype (parse-foreign-type result-spec)))
489      (when (typep rtype 'foreign-record-type)
490        (if (x8664::record-type-returns-structure-as-first-arg rtype)
491          (setq argvars (cons struct-result-name argvars)
492                argspecs (cons :address argspecs)
493                rtype *void-foreign-type*)
494          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
495      (do* ((argvars argvars (cdr argvars))
496            (argspecs argspecs (cdr argspecs))
497            (gpr-arg-num 0)
498            (gpr-arg-offset -8)
499            (fpr-arg-num 0)
500            (fpr-arg-offset -56)
501            (memory-arg-offset 16)
502            (fp nil nil))
503           ((null argvars)
504            (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 8))
505        (flet ((next-gpr ()
506                 (if (<= (incf gpr-arg-num) 6)
507                   (prog1
508                       gpr-arg-offset
509                     (decf gpr-arg-offset 8))
510                   (prog1
511                       memory-arg-offset
512                     (incf memory-arg-offset 8))))
513               (next-fpr ()
514                 (if (<= (incf fpr-arg-num) 8)
515                   (prog1
516                       fpr-arg-offset
517                     (decf fpr-arg-offset 8))
518                   (prog1
519                       memory-arg-offset
520                     (incf memory-arg-offset 8)))))
521          (let* ((name (car argvars))
522                 (spec (car argspecs))
523                 (argtype (parse-foreign-type spec))
524                 (bits (require-foreign-type-bits argtype)))
525            (if (typep argtype 'foreign-record-type)
526              (multiple-value-bind (first8 second8)
527                  (x8664::classify-record-type argtype)
528                (let* ((gprs (- 6 gpr-arg-num))
529                       (fprs (- 8 fpr-arg-num)))
530                  (case first8
531                    (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
532                    (:float (if (< (decf fprs) 0) (setq first8 :memory))))
533                  (case second8
534                    (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
535                    (:float (if (< (decf fprs) 0) (setq first8 :memory)))))
536                (if (eq first8 :memory)
537                  (progn
538                    (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset
539                                                                   (incf memory-arg-offset (* 8 (ceiling bits 64)))))))
540                         (dynamic-extent-names name))
541                  (progn
542                    (rlets (list name (foreign-record-type-name argtype)))
543                    (inits `(setf (%%get-unsigned-longlong ,name 0)
544                             (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr)))))
545                    (if second8
546                      (inits `(setf (%%get-unsigned-longlong ,name 8)
547                             (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr)))))))))
548                (lets (list name
549                            `(,
550                             (ecase (foreign-type-to-representation-type argtype)
551                               (:single-float (setq fp t) '%get-single-float)
552                               (:double-float (setq fp t) '%get-double-float)
553                               (:signed-doubleword  '%%get-signed-longlong)
554                               (:signed-fullword '%get-signed-long)
555                               (:signed-halfword '%get-signed-word)
556                               (:signed-byte '%get-signed-byte)
557                               (:unsigned-doubleword '%%get-unsigned-longlong)
558                               (:unsigned-fullword '%get-unsigned-long)
559                               (:unsigned-halfword '%get-unsigned-word)
560                               (:unsigned-byte '%get-unsigned-byte)
561                               (:address
562                                #+nil
563                                (dynamic-extent-names name)
564                                '%get-ptr))
565                             ,stack-ptr
566                             ,(if fp (next-fpr) (next-gpr))))))))))))
567
568(defun x8664::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
569  (declare (ignore fp-args-ptr))
570  (unless (eq return-type *void-foreign-type*)
571    (let* ((gpr-offset -8)
572           (fpr-offset -24))
573      (if (typep return-type 'foreign-record-type)
574      ;;; Would have been mapped to :VOID unless record-type was <= 128 bits.
575        (collect ((forms))
576          (multiple-value-bind (first8 second8)
577              (x8664::classify-record-type return-type)
578            (forms `(setf (%%get-signed-longlong ,stack-ptr ,(if (eq first8 :integer) gpr-offset fpr-offset))
579                     (%%get-signed-longlong ,struct-return-arg 0)))
580            (when second8
581              (if (eq first8 :integer) (decf gpr-offset 8) (decf fpr-offset 8))
582              (forms `(setf (%%get-signed-longlong ,stack-ptr ,(if (eq first8 :integer) gpr-offset fpr-offset))
583                       (%%get-signed-longlong ,struct-return-arg 8))))
584            `(progn ,@(forms))))
585        (let* ((return-type-keyword (foreign-type-to-representation-type return-type))
586               (offset (case return-type-keyword
587                         ((:single-float :double-float) fpr-offset)
588                         (t gpr-offset))))
589          `(setf (,
590                  (case return-type-keyword
591                    (:address '%get-ptr)
592                    (:signed-doubleword '%%get-signed-longlong)
593                    (:unsigned-doubleword '%%get-unsigned-longlong)
594                    (:double-float '%get-double-float)
595                    (:single-float '%get-single-float)
596                    (:unsigned-fullword '%get-unsigned-long)
597                    (t '%%get-signed-longlong )
598                    ) ,stack-ptr ,offset) ,result))))))
599
600
601
602#+x8664-target
603(require "X8664-VINSNS")
604
605(provide "X8664-BACKEND")
Note: See TracBrowser for help on using the repository browser.