source: trunk/source/compiler/X86/X8632/x8632-backend.lisp @ 11550

Last change on this file since 11550 was 11550, checked in by rme, 13 years ago

Start to factor out of some the x8632 ffi stuff that's shared by
multiple platforms.

File size: 18.7 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2
3(in-package "CCL")
4(eval-when (:compile-toplevel :load-toplevel :execute)
5  (require "BACKEND"))
6
7(eval-when (:compile-toplevel :execute)
8  (require "NXENV")
9  (require "X8632ENV"))
10
11(defvar *x8632-vinsn-templates* (make-hash-table :test #'eq))
12
13(defvar *known-x8632-backends* ())
14
15#+darwinx86-target
16(defvar *darwinx8632-backend*
17  (make-backend :lookup-opcode 'lookup-x86-opcode
18                :lookup-macro #'false
19                :lap-opcodes x86::*x86-opcode-templates*
20                :define-vinsn 'define-x86-vinsn
21                :p2-dispatch *x862-specials*
22                :p2-vinsn-templates *x8632-vinsn-templates*
23                :p2-template-hash-name '*x8632-vinsn-templates*
24                :p2-compile 'x862-compile
25                :platform-syscall-mask (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) 
26                :target-specific-features
27                '(:x8632 :x86-target :darwin-target :darwinx86-target :x8632-target
28                  :darwinx8632-target
29                  :little-endian-target
30                  :32-bit-target)
31                :target-fasl-pathname (make-pathname :type "dx32fsl")
32                :target-platform (logior platform-cpu-x86
33                                         platform-os-darwin
34                                         platform-word-size-32)
35                :target-os :darwinx86
36                :name :darwinx8632
37                :target-arch-name :x8632
38                :target-foreign-type-data nil
39                :target-arch x8632::*x8632-target-arch*
40                :lisp-context-register x8632::fs
41                :num-arg-regs 2
42                ))
43
44
45#+darwinx86-target
46(pushnew *darwinx8632-backend* *known-x8632-backends* :key #'backend-name)
47
48#+linuxx86-target
49(defvar *linuxx8632-backend*
50  (make-backend :lookup-opcode 'lookup-x86-opcode
51                :lookup-macro #'false
52                :lap-opcodes x86::*x86-opcode-templates*
53                :define-vinsn 'define-x86-vinsn
54                :p2-dispatch *x862-specials*
55                :p2-vinsn-templates *x8632-vinsn-templates*
56                :p2-template-hash-name '*x8632-vinsn-templates*
57                :p2-compile 'x862-compile
58                :platform-syscall-mask (logior platform-os-linux platform-cpu-x86 platform-word-size-32) 
59                :target-specific-features
60                '(:x8632 :x86-target :linux-target :linuxx86-target :x8632-target
61                  :linuxx8632-target
62                  :little-endian-target
63                  :32-bit-target)
64                :target-fasl-pathname (make-pathname :type "lx32fsl")
65                :target-platform (logior platform-cpu-x86
66                                         platform-os-linux
67                                         platform-word-size-32)
68                :target-os :linuxx86
69                :name :linuxx8632
70                :target-arch-name :x8632
71                :target-foreign-type-data nil
72                :target-arch x8632::*x8632-target-arch*
73                :lisp-context-register x8632::fs
74                :num-arg-regs 2
75                ))
76
77#+linuxx86-target
78(pushnew *linuxx8632-backend* *known-x8632-backends* :key #'backend-name)
79
80#+windows-target
81(defvar *win32-backend*
82  (make-backend :lookup-opcode 'lookup-x86-opcode
83                :lookup-macro #'false
84                :lap-opcodes x86::*x86-opcode-templates*
85                :define-vinsn 'define-x86-vinsn
86                :p2-dispatch *x862-specials*
87                :p2-vinsn-templates *x8632-vinsn-templates*
88                :p2-template-hash-name '*x8632-vinsn-templates*
89                :p2-compile 'x862-compile
90                :platform-syscall-mask (logior platform-os-windows platform-cpu-x86 platform-word-size-32) 
91                :target-specific-features
92                '(:x8632 :x86-target :windows-target :win32-target :x8632-target
93                  :windowsx8632-target
94                  :little-endian-target
95                  :32-bit-target)
96                :target-fasl-pathname (make-pathname :type "wx32fsl")
97                :target-platform (logior platform-cpu-x86
98                                         platform-os-windows
99                                         platform-word-size-32)
100                :target-os :win32
101                :name :win32
102                :target-arch-name :x8632
103                :target-foreign-type-data nil
104                :target-arch x8632::*x8632-target-arch*
105                :lisp-context-register x8632::es
106                :num-arg-regs 2
107                ))
108
109#+windows-target
110(pushnew *win32-backend* *known-x8632-backends* :key #'backend-name)
111
112#+solaris-target
113(defvar *solaris-x8632-backend*
114  (make-backend :lookup-opcode 'lookup-x86-opcode
115                :lookup-macro #'false
116                :lap-opcodes x86::*x86-opcode-templates*
117                :define-vinsn 'define-x86-vinsn
118                :p2-dispatch *x862-specials*
119                :p2-vinsn-templates *x8632-vinsn-templates*
120                :p2-template-hash-name '*x8632-vinsn-templates*
121                :p2-compile 'x862-compile
122                :platform-syscall-mask (logior platform-os-solaris platform-cpu-x86 platform-word-size-32) 
123                :target-specific-features
124                '(:x8632 :x86-target :solaris-target :x8632-target
125                  :solarisx8632-target
126                  :little-endian-target
127                  :32-bit-target)
128                :target-fasl-pathname (make-pathname :type "sx32fsl")
129                :target-platform (logior platform-cpu-x86
130                                         platform-os-solaris
131                                         platform-word-size-32)
132                :target-os :solarisx8632
133                :name :solarisx8632
134                :target-arch-name :x8632
135                :target-foreign-type-data nil
136                :target-arch x8632::*x8632-target-arch*
137                :lisp-context-register x8632::fs
138                :num-arg-regs 2
139                ))
140#+solaris-target
141(pushnew *solaris-x8632-backend* *known-x8632-backends* :key #'backend-name)
142
143#+freebsd-target
144(defvar *freebsd-x8632-backend*
145  (make-backend :lookup-opcode 'lookup-x86-opcode
146                :lookup-macro #'false
147                :lap-opcodes x86::*x86-opcode-templates*
148                :define-vinsn 'define-x86-vinsn
149                :p2-dispatch *x862-specials*
150                :p2-vinsn-templates *x8632-vinsn-templates*
151                :p2-template-hash-name '*x8632-vinsn-templates*
152                :p2-compile 'x862-compile
153                :platform-syscall-mask (logior platform-os-freebsd platform-cpu-x86 platform-word-size-32) 
154                :target-specific-features
155                '(:x8632 :x86-target :freebsd-target :x8632-target
156                  :freebsdsx8632-target
157                  :little-endian-target
158                  :32-bit-target)
159                :target-fasl-pathname (make-pathname :type "fx32fsl")
160                :target-platform (logior platform-cpu-x86
161                                         platform-os-freebsd
162                                         platform-word-size-32)
163                :target-os :freebsdx8632
164                :name :freebsdx8632
165                :target-arch-name :x8632
166                :target-foreign-type-data nil
167                :target-arch x8632::*x8632-target-arch*
168                :lisp-context-register x8632::fs
169                :num-arg-regs 2
170                ))
171
172#+freebsd-target
173(pushnew *freebsd-x8632-backend* *known-x8632-backends* :key #'backend-name)
174
175(defvar *x8632-backend* (car *known-x8632-backends*))
176
177(defun fixup-x8632-backend ()
178  (dolist (b *known-x8632-backends*)
179    (setf #| (backend-lap-opcodes b) x86::*x86-opcodes* |#
180          (backend-p2-dispatch b) *x862-specials*
181          (backend-p2-vinsn-templates b)  *x8632-vinsn-templates*)
182    (or (backend-lap-macros b) (setf (backend-lap-macros b)
183                                     (make-hash-table :test #'equalp)))))
184
185
186(fixup-x8632-backend)
187
188#+x8632-target
189(setq *host-backend* *x8632-backend* *target-backend* *x8632-backend*)
190
191
192(defun setup-x8632-ftd (backend)
193  (or (backend-target-foreign-type-data backend)
194      (let* ((name (backend-name backend))
195             (ftd
196              (case name
197                (:darwinx8632
198                 (make-ftd :interface-db-directory "ccl:darwin-x86-headers;"
199                           :interface-package-name "X86-DARWIN32"
200                           :attributes '(:bits-per-word  32
201                                         :signed-char t
202                                         :struct-by-value t
203                                         :prepend-underscore t)
204                           :ff-call-expand-function
205                           (intern "EXPAND-FF-CALL" "X86-DARWIN32")
206                           :ff-call-struct-return-by-implicit-arg-function
207                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
208                                   "X86-DARWIN32")
209                           :callback-bindings-function
210                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-DARWIN32")
211                           :callback-return-value-function
212                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-DARWIN32")))
213                (:linuxx8632
214                 (make-ftd :interface-db-directory "ccl:x86-headers;"
215                           :interface-package-name "X86-LINUX32"
216                           :attributes '(:bits-per-word  32
217                                         :signed-char nil
218                                         :struct-by-value t
219                                         :float-results-in-x87 t)
220                           :ff-call-expand-function
221                           (intern "EXPAND-FF-CALL" "X86-LINUX32")
222                           :ff-call-struct-return-by-implicit-arg-function
223                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
224                                   "X86-LINUX32")
225                           :callback-bindings-function
226                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-LINUX32")
227                           :callback-return-value-function
228                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-LINUX32")))
229                (:win32
230                 (make-ftd :interface-db-directory "ccl:win32-headers;"
231                           :interface-package-name "WIN32"
232                           :attributes '(:bits-per-word  32
233                                         :signed-char nil
234                                         :struct-by-value t
235                                         :float-results-in-x87 t)
236                           :ff-call-expand-function
237                           (intern "EXPAND-FF-CALL" "WIN32")
238                           :ff-call-struct-return-by-implicit-arg-function
239                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
240                                   "WIN32")
241                           :callback-bindings-function
242                           (intern "GENERATE-CALLBACK-BINDINGS" "WIN32")
243                           :callback-return-value-function
244                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "WIN32")))
245                (:solarisx8632
246                 (make-ftd :interface-db-directory "ccl:solarisx86-headers;"
247                           :interface-package-name "X86-SOLARIS32"
248                           :attributes '(:bits-per-word  32
249                                         :signed-char nil
250                                         :struct-by-value t
251                                         :float-results-in-x87 t)
252                           :ff-call-expand-function
253                           (intern "EXPAND-FF-CALL" "X86-SOLARIS32")
254                           :ff-call-struct-return-by-implicit-arg-function
255                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
256                                   "X86-SOLARIS32")
257                           :callback-bindings-function
258                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-SOLARIS32")
259                           :callback-return-value-function
260                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-SOLARIS32")))
261                (:freebsdx8632
262                 (make-ftd :interface-db-directory "ccl:freebsd-headers;"
263                           :interface-package-name "X86-FREEBSD32"
264                           :attributes '(:bits-per-word  32
265                                         :signed-char nil
266                                         :struct-by-value t
267                                         :float-results-in-x87 t)
268                           :ff-call-expand-function
269                           (intern "EXPAND-FF-CALL" "X86-FREEBSD32")
270                           :ff-call-struct-return-by-implicit-arg-function
271                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
272                                   "X86-FREEBSD32")
273                           :callback-bindings-function
274                           (intern "GENERATE-CALLBACK-BINDINGS" "X86-FREEBSD32")
275                           :callback-return-value-function
276                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-FREEBSD32")))
277                )))
278        (install-standard-foreign-types ftd)
279        (use-interface-dir :libc ftd)
280        (setf (backend-target-foreign-type-data backend) ftd))))
281
282#-x8632-target
283(setup-x8632-ftd *x8632-backend*)
284
285(pushnew *x8632-backend* *known-backends* :key #'backend-name)
286
287;;; FFI stuff.  Shared by several backends (Darwin notably excepted.)
288
289;;; A returned structure is always passed as a "hidden" first argument.
290(defun x8632::record-type-returns-structure-as-first-arg (rtype)
291  (declare (ignore rtype))
292  t)
293
294;;; All arguments are passed on the stack.
295;;;
296;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
297
298(defun x8632::expand-ff-call (callform args
299                              &key (arg-coerce #'null-coerce-foreign-arg)
300                              (result-coerce #'null-coerce-foreign-result))
301  (let* ((result-type-spec (or (car (last args)) :void))
302         (result-form nil))
303    (multiple-value-bind (result-type error)
304        (ignore-errors (parse-foreign-type result-type-spec))
305      (if error
306        (setq result-type-spec :void result-type *void-foreign-type*)
307        (setq args (butlast args)))
308      (collect ((argforms))
309        (when (typep result-type 'foreign-record-type)
310          (setq result-form (pop args)
311                result-type *void-foreign-type*
312                result-type-spec :void)
313          (argforms :address)
314          (argforms result-form))
315        (unless (evenp (length args))
316          (error "~s should be an even-length list of alternating foreign types and values" args))
317        (do* ((args args (cddr args)))
318             ((null args))
319          (let* ((arg-type-spec (car args))
320                 (arg-value-form (cadr args)))
321            (if (or (member arg-type-spec *foreign-representation-type-keywords*
322                            :test #'eq)
323                    (typep arg-type-spec 'unsigned-byte))
324              (progn
325                (argforms arg-type-spec)
326                (argforms arg-value-form))
327              (let* ((ftype (parse-foreign-type arg-type-spec))
328                     (bits (ensure-foreign-type-bits ftype)))
329                (when (and (typep ftype 'foreign-record-type)
330                           (eq (foreign-record-type-kind ftype)
331                               :transparent-union))
332                  (ensure-foreign-type-bits ftype)
333                  (setq ftype (foreign-record-field-type
334                               (car (foreign-record-type-fields ftype)))
335                        arg-type-spec (foreign-type-to-representation-type
336                                       ftype)
337                        bits (ensure-foreign-type-bits ftype)))
338                    (if (typep ftype 'foreign-record-type)
339                      (argforms (ceiling bits 32))
340                      (argforms (foreign-type-to-representation-type ftype)))
341                (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
342          (argforms (foreign-type-to-representation-type result-type))
343          (funcall result-coerce result-type-spec
344                   `(,@callform ,@(argforms)))))))
345
346
347;;; Return 7 values:
348;;; A list of RLET bindings
349;;; A list of LET* bindings
350;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
351;;; A list of initializaton forms for (some) structure args (not used on x8632)
352;;; A FOREIGN-TYPE representing the "actual" return type.
353;;; A form which can be used to initialize FP-ARGS-PTR, relative
354;;;  to STACK-PTR.  (This is unused on x8632.)
355;;; The byte offset of the foreign return address, relative to STACK-PTR
356
357(defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars
358                                          argspecs result-spec
359                                          struct-result-name)
360  (declare (ignore fp-args-ptr))
361  (collect ((lets)
362            (dynamic-extent-names))
363    (let* ((rtype (parse-foreign-type result-spec)))
364      (when (typep rtype 'foreign-record-type)
365        (setq argvars (cons struct-result-name argvars)
366              argspecs (cons :address argspecs)
367              rtype *void-foreign-type*))
368      (do* ((argvars argvars (cdr argvars))
369            (argspecs argspecs (cdr argspecs))
370            (offset 8))
371           ((null argvars)
372            (values nil (lets) (dynamic-extent-names) nil rtype nil 4))
373        (let* ((name (car argvars))
374               (spec (car argspecs))
375               (argtype (parse-foreign-type spec))
376               (bits (require-foreign-type-bits argtype))
377               (double nil))
378          (if (typep argtype 'foreign-record-type)
379            (lets (list name
380                        `(%inc-ptr ,stack-ptr
381                                   ,(prog1 offset
382                                           (incf offset
383                                                 (* 4 (ceiling bits 32)))))))
384            (progn
385              (lets (list name
386                          `(,
387                            (ecase (foreign-type-to-representation-type argtype)
388                              (:single-float '%get-single-float)
389                              (:double-float (setq double t) '%get-double-float)
390                              (:signed-doubleword (setq double t)
391                                                  '%%get-signed-longlong)
392                              (:signed-fullword '%get-signed-long)
393                              (:signed-halfword '%get-signed-word)
394                              (:signed-byte '%get-signed-byte)
395                              (:unsigned-doubleword (setq double t)
396                                                    '%%get-unsigned-longlong)
397                              (:unsigned-fullword '%get-unsigned-long)
398                              (:unsigned-halfword '%get-unsigned-word)
399                              (:unsigned-byte '%get-unsigned-byte)
400                              (:address '%get-ptr))
401                            ,stack-ptr
402                            ,offset)))
403              (incf offset 4)
404              (when double (incf offset 4)))))))))
405
406(defun x8632::generate-callback-return-value (stack-ptr fp-args-ptr result
407                                              return-type struct-return-arg)
408  (declare (ignore fp-args-ptr struct-return-arg))
409  (unless (eq return-type *void-foreign-type*)
410    (let* ((return-type-keyword (foreign-type-to-representation-type
411                                 return-type)))
412        (collect ((forms))
413          (forms 'progn)
414          (case return-type-keyword
415            (:single-float
416             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
417            (:double-float
418             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
419          (forms
420           `(setf (,
421                   (case return-type-keyword
422                     (:address '%get-ptr)
423                     (:signed-doubleword '%%get-signed-longlong)
424                     (:unsigned-doubleword '%%get-unsigned-longlong)
425                     (:double-float '%get-double-float)
426                     (:single-float '%get-single-float)
427                     (:unsigned-fullword '%get-unsigned-long)
428                     (t '%get-signed-long)
429                     ) ,stack-ptr -8) ,result))
430          (forms)))))
431
432
433
434#+x8632-target
435(require "X8632-VINSNS")
436
437(provide "X8632-BACKEND")
438
Note: See TracBrowser for help on using the repository browser.