source: branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp @ 7624

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

Merge changes form working-0710 branch.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.8 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#+(or linuxx86-target (not x86-target))
122(pushnew *linuxx8664-backend* *known-x8664-backends* :key #'backend-name)
123
124
125#+darwinx86-target
126(pushnew *darwinx8664-backend* *known-x8664-backends* :key #'backend-name)
127
128#+freebsdx86-target
129(pushnew *freebsdx8664-backend* *known-x8664-backends* :key #'backend-name)
130
131(defvar *x8664-backend* (car *known-x8664-backends*))
132
133(defun fixup-x8664-backend ()
134  (dolist (b *known-x8664-backends*)
135    (setf #| (backend-lap-opcodes b) x86::*x86-opcodes* |#
136          (backend-p2-dispatch b) *x862-specials*
137          (backend-p2-vinsn-templates b)  *x8664-vinsn-templates*)
138    (or (backend-lap-macros b) (setf (backend-lap-macros b)
139                                     (make-hash-table :test #'equalp)))))
140
141
142
143(fixup-x8664-backend)
144
145#+x8664-target
146(setq *host-backend* *x8664-backend* *target-backend* *x8664-backend*)
147
148(defun setup-x8664-ftd (backend)
149  (or (backend-target-foreign-type-data backend)
150      (let* ((name (backend-name backend))
151             (ftd
152              (case name
153                (:linuxx8664
154                 (make-ftd :interface-db-directory
155                           (if (eq backend *host-backend*)
156                             "ccl:x86-headers64;"
157                             "ccl:cross-x86-headers64;")
158                           :interface-package-name "X86-LINUX64"
159                           :attributes '(:bits-per-word  64
160                                         :struct-by-value t)
161                           :ff-call-expand-function
162                           (intern "EXPAND-FF-CALL" "X86-LINUX64")
163                           :ff-call-struct-return-by-implicit-arg-function
164                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
165                                   "X86-LINUX64")
166                           :callback-bindings-function
167                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-LINUX64")
168                           :callback-return-value-function
169                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-LINUX64")))
170                (:darwinx8664
171                 (make-ftd :interface-db-directory
172                           (if (eq backend *host-backend*)
173                             "ccl:darwin-x86-headers64;"
174                             "ccl:cross-darwin-x86-headers64;")
175                           :interface-package-name "X86-DARWIN64"
176                           :attributes '(:bits-per-word  64
177                                         :signed-char t
178                                         :struct-by-value t
179                                         :prepend-underscore t)
180                           :ff-call-expand-function
181                           (intern "EXPAND-FF-CALL" "X86-DARWIN64")
182                           :ff-call-struct-return-by-implicit-arg-function
183                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
184                                   "X86-DARWIN64")
185                           :callback-bindings-function
186                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-DARWIN64")
187                           :callback-return-value-function
188                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-DARWIN64")))
189                (:freebsdx8664
190                 (make-ftd :interface-db-directory
191                           (if (eq backend *host-backend*)
192                             "ccl:freebsd-headers64;"
193                             "ccl:cross-freebsd-headers64;")
194                           :interface-package-name "X86-FREEBSD64"
195                           :attributes '(:bits-per-word  64
196                                         :struct-by-value t)
197                           :ff-call-expand-function
198                           (intern "EXPAND-FF-CALL" "X86-FREEBSD64")
199                           :ff-call-struct-return-by-implicit-arg-function
200                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
201                                   "X86-FREEBSD64")
202                           :callback-bindings-function
203                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-FREEBSD64")
204                           :callback-return-value-function
205                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-FREEBSD64"))))))
206        (install-standard-foreign-types ftd)
207        (use-interface-dir :libc ftd)
208        (setf (backend-target-foreign-type-data backend) ftd))))
209
210#-x8664-target
211(setup-x8664-ftd *x8664-backend*)
212
213(pushnew *x8664-backend* *known-backends* :key #'backend-name)
214
215;;; FFI stuff.  Seems to be shared by Darwin/Linux/FreeBSD.
216
217;;; A returned structure is passed as an invisible first argument if
218;;; it's more than 2 doublewords long or if it contains unaligned fields.
219;;; Not clear how the latter case can happen, so this just checks for
220;;; the first.
221(defun x8664::record-type-returns-structure-as-first-arg (rtype)
222  (when (and rtype
223             (not (typep rtype 'unsigned-byte))
224             (not (member rtype *foreign-representation-type-keywords*
225                          :test #'eq)))
226    (let* ((ftype (if (typep rtype 'foreign-type)
227                    rtype
228                    (parse-foreign-type rtype))))
229      (> (ensure-foreign-type-bits ftype) 128))))
230
231;;; On x8664, structures can be passed by value:
232;;;  a) in memory, if they're more than 128 bits in size or if there aren't
233;;;     enough of the right kind of register to pass them entirely in registers.
234;;;  b) as a series of 64-bit chunks, passed in GPRs if any component of the
235;;;     chunk is a non FLOAT or in FPRs otherwise.
236;;; Note that this means that a chunk consisting of two SINGLE-FLOATs would
237;;; be passed in the low 64 bit of an SSE (xmm) register.
238
239(defun x8664::field-is-of-class-integer (field)
240  ;; Return true if field is of "class" integer or if it's a record
241  ;; type of class integer.  (See the System V AMD64 ABI document for
242  ;; a convoluted definition of field "classes".)
243  (let* ((ftype (foreign-record-field-type field)))
244    (typecase ftype
245      ((or foreign-integer-type foreign-pointer-type) t)
246      (foreign-record-type (dolist (f (foreign-record-type-fields ftype))
247                             (when (x8664::field-is-of-class-integer f)
248                               (return t))))
249      (otherwise nil))))
250
251(defun x8664::classify-8byte (field-list bit-limit)
252  ;; CDR down the fields in FIELD-LIST until we find a field of class integer,
253  ;; hit the end of the list, or find a field whose offset is >= BIT-LIMIT.
254  ;; In the first case, return :INTEGER.  In other cases, return :FLOAT.
255  (dolist (field field-list :float)
256    (if (<= bit-limit (foreign-record-field-offset field))
257      (return :float)
258      (if (x8664::field-is-of-class-integer field)
259        (return :integer)))))
260
261;;; Return a first value :memory, :integer, or::float and a second
262;;; value of NIL, :integer, or :float according to how the structure
263;;; RTYPE should ideally be passed or returned.  Note that the caller
264;;; may decide to turn this to :memory if there aren't enough
265;;; available registers of the right class when passing an instance of
266;;; this structure type.
267(defun x8664::classify-record-type (rtype)
268  (let* ((nbits (ensure-foreign-type-bits rtype))
269         (fields (foreign-record-type-fields rtype)))
270    (cond ((> nbits 128) (values :memory nil))
271          ((<= nbits 64) (values (x8664::classify-8byte fields 64) nil))
272          (t (values (x8664::classify-8byte fields 64)
273               (do* ()
274                    ((>= (foreign-record-field-offset (car fields)) 64)
275                     (x8664::classify-8byte fields 128))
276                 (setq fields (cdr fields))))))))
277
278(defun x8664::struct-from-regbuf-values (r rtype regbuf)
279  (multiple-value-bind (first second)
280      (x8664::classify-record-type rtype)
281    (let* ((gpr-offset 0)
282           (fpr-offset 16))
283      ;; Do this 32 bits at a time, to avoid consing.
284      (collect ((forms))
285        (case first
286          (:integer (forms `(setf (%get-unsigned-long ,r 0)
287                             (%get-unsigned-long ,regbuf 0)))
288                    (forms `(setf (%get-unsigned-long ,r 4)
289                             (%get-unsigned-long ,regbuf 4)))
290                    (setq gpr-offset 8))
291          (:float (forms `(setf (%get-unsigned-long ,r 0)
292                             (%get-unsigned-long ,regbuf 16)))
293                  (forms `(setf (%get-unsigned-long ,r 4)
294                             (%get-unsigned-long ,regbuf 20)))
295                  (setf fpr-offset 24)))
296        (case second
297          (:integer (forms `(setf (%get-unsigned-long ,r 8)
298                             (%get-unsigned-long ,regbuf ,gpr-offset)))
299                    (forms `(setf (%get-unsigned-long ,r 12)
300                             (%get-unsigned-long ,regbuf ,(+ gpr-offset 4)))))
301          (:float (forms `(setf (%get-unsigned-long ,r 8)
302                             (%get-unsigned-long ,regbuf ,fpr-offset)))
303                  (forms `(setf (%get-unsigned-long ,r 12)
304                             (%get-unsigned-long ,regbuf ,(+ fpr-offset 4))))))
305        `(progn ,@(forms))))))
306
307(defun x8664::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
308  (let* ((result-type-spec (or (car (last args)) :void))
309         (regbuf nil)
310         (result-temp nil)
311         (result-form nil)
312         (struct-result-type nil)
313         (structure-arg-temp nil))
314    (multiple-value-bind (result-type error)
315        (ignore-errors (parse-foreign-type result-type-spec))
316      (if error
317        (setq result-type-spec :void result-type *void-foreign-type*)
318        (setq args (butlast args)))
319      (collect ((argforms))
320        (when (eq (car args) :monitor-exception-ports)
321          (argforms (pop args)))
322        (when (typep result-type 'foreign-record-type)
323          (setq result-form (pop args)
324                struct-result-type result-type
325                result-type *void-foreign-type*
326                result-type-spec :void)
327          (if (x8664::record-type-returns-structure-as-first-arg struct-result-type)
328            (progn
329              (argforms :address)
330              (argforms result-form))
331            (progn
332              (setq regbuf (gensym)
333                    result-temp (gensym))
334              (argforms :registers)
335              (argforms regbuf))))
336        (let* ((valform nil))
337                      (unless (evenp (length args))
338              (error "~s should be an even-length list of alternating foreign types and values" args))
339            (do* ((args args (cddr args))
340                  (remaining-gprs 6)
341                  (remaining-fprs 8))
342                 ((null args))
343              (let* ((arg-type-spec (car args))
344                     (arg-value-form (cadr args)))
345                (if (or (member arg-type-spec *foreign-representation-type-keywords*
346                                :test #'eq)
347                        (typep arg-type-spec 'unsigned-byte))
348                  (progn
349                    (if (or (eq arg-type-spec :double-float)
350                            (eq arg-type-spec :single-float))
351                      (decf remaining-fprs)
352                      (unless (typep arg-type-spec 'unsigned-byte)
353                        (decf remaining-gprs)))
354                    (argforms arg-type-spec)
355                    (argforms arg-value-form))
356                  (let* ((ftype (parse-foreign-type arg-type-spec)))
357                    (if (typep ftype 'foreign-record-type)
358                      (multiple-value-bind (first8 second8)
359                          (x8664::classify-record-type ftype)
360                        (let* ((gprs remaining-gprs)
361                               (fprs remaining-fprs))
362                          (case first8
363                            (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
364                            (:float (if (< (decf fprs) 0) (setq first8 :memory))))
365                          (case second8
366                            (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
367                            (:float (if (< (decf fprs) 0) (setq first8 :memory)))))
368                        (if (eq first8 :memory)
369                          (progn
370                            (argforms (ceiling (foreign-record-type-bits ftype) 64))
371                            (argforms arg-value-form))
372                          (progn
373                            (if second8
374                              (progn
375                                (unless structure-arg-temp
376                                  (setq structure-arg-temp (gensym)))
377                                (setq valform `(%setf-macptr ,structure-arg-temp ,arg-value-form)))
378                              (setq valform arg-value-form))
379                            (if (eq first8 :float)
380                              (progn
381                                (decf remaining-fprs)
382                                (argforms :double-float)
383                                (argforms `(%get-double-float ,valform 0)))
384                              (progn
385                                (decf remaining-gprs)
386                                (argforms :unsigned-doubleword)
387                                (argforms `(%%get-unsigned-longlong ,valform 0))))
388                            (when second8
389                              (setq valform structure-arg-temp)
390                              (if (eq second8 :float)
391                                (progn
392                                (decf remaining-fprs)
393                                (argforms :double-float)
394                                (argforms `(%get-double-float ,valform 8)))
395                              (progn
396                                (decf remaining-gprs)
397                                (argforms :unsigned-doubleword)
398                                (argforms `(%%get-unsigned-longlong ,valform 8))))))))
399                      (let* ((rtype (foreign-type-to-representation-type ftype)))
400                        (if (or (eq rtype :singlefloat) (eq rtype :double-float))
401                          (decf remaining-fprs)
402                          (decf remaining-gprs))
403                        (argforms rtype)
404                        (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
405            (argforms (foreign-type-to-representation-type result-type))
406            (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
407              (when structure-arg-temp
408                (setq call `(let* ((,structure-arg-temp (%null-ptr)))
409                             (declare (dynamic-extent ,structure-arg-temp)
410                                      (type macptr ,structure-arg-temp))
411                             ,call)))
412              (if regbuf
413                `(let* ((,result-temp (%null-ptr)))
414                  (declare (dynamic-extent ,result-temp)
415                           (type macptr ,result-temp))
416                  (%setf-macptr ,result-temp ,result-form)
417                  (%stack-block ((,regbuf (+ (* 2 8) (* 2 8))))
418                    ,call
419                    ,(x8664::struct-from-regbuf-values result-temp struct-result-type regbuf)))
420                call)))))))
421
422
423;;; Return 7 values:
424;;; A list of RLET bindings
425;;; A list of LET* bindings
426;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
427;;; A list of initializaton forms for (some) structure args
428;;; A FOREIGN-TYPE representing the "actual" return type.
429;;; A form which can be used to initialize FP-ARGS-PTR, relative
430;;;  to STACK-PTR.  (This is unused on linuxppc32.)
431;;; The byte offset of the foreign return address, relative to STACK-PTR
432
433(defun x8664::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
434  (declare (ignore fp-args-ptr))
435  (collect ((lets)
436            (rlets)
437            (inits)
438            (dynamic-extent-names))
439    (let* ((rtype (parse-foreign-type result-spec)))
440      (when (typep rtype 'foreign-record-type)
441        (if (x8664::record-type-returns-structure-as-first-arg rtype)
442          (setq argvars (cons struct-result-name argvars)
443                argspecs (cons :address argspecs)
444                rtype *void-foreign-type*)
445          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
446      (do* ((argvars argvars (cdr argvars))
447            (argspecs argspecs (cdr argspecs))
448            (gpr-arg-num 0)
449            (gpr-arg-offset -8)
450            (fpr-arg-num 0)
451            (fpr-arg-offset -56)
452            (memory-arg-offset 16)
453            (fp nil nil))
454           ((null argvars)
455            (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 8))
456        (flet ((next-gpr ()
457                 (if (<= (incf gpr-arg-num) 6)
458                   (prog1
459                       gpr-arg-offset
460                     (decf gpr-arg-offset 8))
461                   (prog1
462                       memory-arg-offset
463                     (incf memory-arg-offset 8))))
464               (next-fpr ()
465                 (if (<= (incf fpr-arg-num) 8)
466                   (prog1
467                       fpr-arg-offset
468                     (decf fpr-arg-offset 8))
469                   (prog1
470                       memory-arg-offset
471                     (incf memory-arg-offset 8)))))
472          (let* ((name (car argvars))
473                 (spec (car argspecs))
474                 (argtype (parse-foreign-type spec))
475                 (bits (require-foreign-type-bits argtype)))
476            (if (typep argtype 'foreign-record-type)
477              (multiple-value-bind (first8 second8)
478                  (x8664::classify-record-type argtype)
479                (let* ((gprs (- 6 gpr-arg-num))
480                       (fprs (- 8 fpr-arg-num)))
481                  (case first8
482                    (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
483                    (:float (if (< (decf fprs) 0) (setq first8 :memory))))
484                  (case second8
485                    (:integer (if (< (decf gprs) 0) (setq first8 :memory)))
486                    (:float (if (< (decf fprs) 0) (setq first8 :memory)))))
487                (if (eq first8 :memory)
488                  (progn
489                    (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset
490                                                                   (incf memory-arg-offset (* 8 (ceiling bits 64)))))))
491                         (dynamic-extent-names name))
492                  (progn
493                    (rlets (list name (foreign-record-type-name argtype)))
494                    (inits `(setf (%%get-unsigned-longlong ,name 0)
495                             (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr)))))
496                    (if second8
497                      (inits `(setf (%%get-unsigned-longlong ,name 8)
498                             (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr)))))))))
499                (lets (list name
500                            `(,
501                             (ecase (foreign-type-to-representation-type argtype)
502                               (:single-float (setq fp t) '%get-single-float)
503                               (:double-float (setq fp t) '%get-double-float)
504                               (:signed-doubleword  '%%get-signed-longlong)
505                               (:signed-fullword '%get-signed-long)
506                               (:signed-halfword '%get-signed-word)
507                               (:signed-byte '%get-signed-byte)
508                               (:unsigned-doubleword '%%get-unsigned-longlong)
509                               (:unsigned-fullword '%get-unsigned-long)
510                               (:unsigned-halfword '%get-unsigned-word)
511                               (:unsigned-byte '%get-unsigned-byte)
512                               (:address
513                                #+nil
514                                (dynamic-extent-names name)
515                                '%get-ptr))
516                             ,stack-ptr
517                             ,(if fp (next-fpr) (next-gpr))))))))))))
518
519(defun x8664::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
520  (declare (ignore fp-args-ptr))
521  (unless (eq return-type *void-foreign-type*)
522    (let* ((gpr-offset -8)
523           (fpr-offset -24))
524      (if (typep return-type 'foreign-record-type)
525      ;;; Would have been mapped to :VOID unless record-type was <= 128 bits.
526        (collect ((forms))
527          (multiple-value-bind (first8 second8)
528              (x8664::classify-record-type return-type)
529            (forms `(setf (%%get-signed-longlong ,stack-ptr ,(if (eq first8 :integer) gpr-offset fpr-offset))
530                     (%%get-signed-longlong ,struct-return-arg 0)))
531            (when second8
532              (if (eq first8 :integer) (decf gpr-offset 8) (decf fpr-offset 8))
533              (forms `(setf (%%get-signed-longlong ,stack-ptr ,(if (eq first8 :integer) gpr-offset fpr-offset))
534                       (%%get-signed-longlong ,struct-return-arg 8))))
535            `(progn ,@(forms))))
536        (let* ((return-type-keyword (foreign-type-to-representation-type return-type))
537               (offset (case return-type-keyword
538                         ((:single-float :double-float) fpr-offset)
539                         (t gpr-offset))))
540          `(setf (,
541                  (case return-type-keyword
542                    (:address '%get-ptr)
543                    (:signed-doubleword '%%get-signed-longlong)
544                    (:unsigned-doubleword '%%get-unsigned-longlong)
545                    (:double-float '%get-double-float)
546                    (:single-float '%get-single-float)
547                    (:unsigned-fullword '%get-unsigned-long)
548                    (t '%%get-signed-longlong )
549                    ) ,stack-ptr ,offset) ,result))))))
550
551
552
553#+x8664-target
554(require "X8664-VINSNS")
555
556(provide "X8664-BACKEND")
Note: See TracBrowser for help on using the repository browser.