source: release/1.4/source/compiler/X86/X8632/x8632-backend.lisp

Last change on this file was 13075, checked in by R. Matthew Emerson, 15 years ago

Merge trunk changes r13066 through r13067.
(copyright notices)
File size: 21.8 KB
RevLine 
[6989]1;;;-*- Mode: Lisp; Package: CCL -*-
2
[13075]3;;; Copyright 2009 Clozure Associates
4;;; This file is part of Clozure CL.
5;;;
6;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU
7;;; Public License , known as the LLGPL and distributed with Clozure
8;;; CL as the file "LICENSE". The LLGPL consists of a preamble and
9;;; the LGPL, which is distributed with Clozure CL as the file "LGPL".
10;;; Where these conflict, the preamble takes precedence.
11;;;
12;;; Clozure CL 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
[6989]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 "X8632ENV"))
24
25(defvar *x8632-vinsn-templates* (make-hash-table :test #'eq))
26
27(defvar *known-x8632-backends* ())
28
[10755]29#+darwinx86-target
[6989]30(defvar *darwinx8632-backend*
31 (make-backend :lookup-opcode 'lookup-x86-opcode
32 :lookup-macro #'false
[7063]33 :lap-opcodes x86::*x86-opcode-templates*
[6989]34 :define-vinsn 'define-x86-vinsn
35 :p2-dispatch *x862-specials*
36 :p2-vinsn-templates *x8632-vinsn-templates*
37 :p2-template-hash-name '*x8632-vinsn-templates*
38 :p2-compile 'x862-compile
39 :platform-syscall-mask (logior platform-os-darwin platform-cpu-x86 platform-word-size-32)
40 :target-specific-features
41 '(:x8632 :x86-target :darwin-target :darwinx86-target :x8632-target
42 :darwinx8632-target
43 :little-endian-target
44 :32-bit-target)
45 :target-fasl-pathname (make-pathname :type "dx32fsl")
46 :target-platform (logior platform-cpu-x86
47 platform-os-darwin
48 platform-word-size-32)
49 :target-os :darwinx86
50 :name :darwinx8632
51 :target-arch-name :x8632
52 :target-foreign-type-data nil
53 :target-arch x8632::*x8632-target-arch*
54 :lisp-context-register x8632::fs
[7311]55 :num-arg-regs 2
[6989]56 ))
57
[10755]58
59#+darwinx86-target
[6989]60(pushnew *darwinx8632-backend* *known-x8632-backends* :key #'backend-name)
61
[10755]62#+linuxx86-target
63(defvar *linuxx8632-backend*
64 (make-backend :lookup-opcode 'lookup-x86-opcode
65 :lookup-macro #'false
66 :lap-opcodes x86::*x86-opcode-templates*
67 :define-vinsn 'define-x86-vinsn
68 :p2-dispatch *x862-specials*
69 :p2-vinsn-templates *x8632-vinsn-templates*
70 :p2-template-hash-name '*x8632-vinsn-templates*
71 :p2-compile 'x862-compile
72 :platform-syscall-mask (logior platform-os-linux platform-cpu-x86 platform-word-size-32)
73 :target-specific-features
74 '(:x8632 :x86-target :linux-target :linuxx86-target :x8632-target
75 :linuxx8632-target
76 :little-endian-target
77 :32-bit-target)
78 :target-fasl-pathname (make-pathname :type "lx32fsl")
79 :target-platform (logior platform-cpu-x86
80 platform-os-linux
81 platform-word-size-32)
82 :target-os :linuxx86
83 :name :linuxx8632
84 :target-arch-name :x8632
85 :target-foreign-type-data nil
86 :target-arch x8632::*x8632-target-arch*
87 :lisp-context-register x8632::fs
88 :num-arg-regs 2
89 ))
90
91#+linuxx86-target
92(pushnew *linuxx8632-backend* *known-x8632-backends* :key #'backend-name)
93
[10905]94#+windows-target
95(defvar *win32-backend*
96 (make-backend :lookup-opcode 'lookup-x86-opcode
97 :lookup-macro #'false
98 :lap-opcodes x86::*x86-opcode-templates*
99 :define-vinsn 'define-x86-vinsn
100 :p2-dispatch *x862-specials*
101 :p2-vinsn-templates *x8632-vinsn-templates*
102 :p2-template-hash-name '*x8632-vinsn-templates*
103 :p2-compile 'x862-compile
104 :platform-syscall-mask (logior platform-os-windows platform-cpu-x86 platform-word-size-32)
105 :target-specific-features
106 '(:x8632 :x86-target :windows-target :win32-target :x8632-target
107 :windowsx8632-target
108 :little-endian-target
109 :32-bit-target)
110 :target-fasl-pathname (make-pathname :type "wx32fsl")
111 :target-platform (logior platform-cpu-x86
112 platform-os-windows
113 platform-word-size-32)
114 :target-os :win32
115 :name :win32
116 :target-arch-name :x8632
117 :target-foreign-type-data nil
118 :target-arch x8632::*x8632-target-arch*
[10925]119 :lisp-context-register x8632::es
[10905]120 :num-arg-regs 2
121 ))
122
123#+windows-target
124(pushnew *win32-backend* *known-x8632-backends* :key #'backend-name)
125
[11254]126#+solaris-target
127(defvar *solaris-x8632-backend*
128 (make-backend :lookup-opcode 'lookup-x86-opcode
129 :lookup-macro #'false
130 :lap-opcodes x86::*x86-opcode-templates*
131 :define-vinsn 'define-x86-vinsn
132 :p2-dispatch *x862-specials*
133 :p2-vinsn-templates *x8632-vinsn-templates*
134 :p2-template-hash-name '*x8632-vinsn-templates*
135 :p2-compile 'x862-compile
136 :platform-syscall-mask (logior platform-os-solaris platform-cpu-x86 platform-word-size-32)
137 :target-specific-features
138 '(:x8632 :x86-target :solaris-target :x8632-target
139 :solarisx8632-target
140 :little-endian-target
141 :32-bit-target)
142 :target-fasl-pathname (make-pathname :type "sx32fsl")
143 :target-platform (logior platform-cpu-x86
144 platform-os-solaris
145 platform-word-size-32)
146 :target-os :solarisx8632
147 :name :solarisx8632
148 :target-arch-name :x8632
149 :target-foreign-type-data nil
150 :target-arch x8632::*x8632-target-arch*
151 :lisp-context-register x8632::fs
152 :num-arg-regs 2
153 ))
154#+solaris-target
155(pushnew *solaris-x8632-backend* *known-x8632-backends* :key #'backend-name)
[10905]156
[11326]157#+freebsd-target
158(defvar *freebsd-x8632-backend*
159 (make-backend :lookup-opcode 'lookup-x86-opcode
160 :lookup-macro #'false
161 :lap-opcodes x86::*x86-opcode-templates*
162 :define-vinsn 'define-x86-vinsn
163 :p2-dispatch *x862-specials*
164 :p2-vinsn-templates *x8632-vinsn-templates*
165 :p2-template-hash-name '*x8632-vinsn-templates*
166 :p2-compile 'x862-compile
167 :platform-syscall-mask (logior platform-os-freebsd platform-cpu-x86 platform-word-size-32)
168 :target-specific-features
169 '(:x8632 :x86-target :freebsd-target :x8632-target
170 :freebsdsx8632-target
171 :little-endian-target
172 :32-bit-target)
173 :target-fasl-pathname (make-pathname :type "fx32fsl")
174 :target-platform (logior platform-cpu-x86
175 platform-os-freebsd
176 platform-word-size-32)
177 :target-os :freebsdx8632
178 :name :freebsdx8632
179 :target-arch-name :x8632
180 :target-foreign-type-data nil
181 :target-arch x8632::*x8632-target-arch*
182 :lisp-context-register x8632::fs
183 :num-arg-regs 2
184 ))
185
186#+freebsd-target
187(pushnew *freebsd-x8632-backend* *known-x8632-backends* :key #'backend-name)
188
[6989]189(defvar *x8632-backend* (car *known-x8632-backends*))
190
191(defun fixup-x8632-backend ()
192 (dolist (b *known-x8632-backends*)
193 (setf #| (backend-lap-opcodes b) x86::*x86-opcodes* |#
194 (backend-p2-dispatch b) *x862-specials*
[7063]195 (backend-p2-vinsn-templates b) *x8632-vinsn-templates*)
[6989]196 (or (backend-lap-macros b) (setf (backend-lap-macros b)
197 (make-hash-table :test #'equalp)))))
198
199
200(fixup-x8632-backend)
201
202#+x8632-target
203(setq *host-backend* *x8632-backend* *target-backend* *x8632-backend*)
204
205
206(defun setup-x8632-ftd (backend)
207 (or (backend-target-foreign-type-data backend)
208 (let* ((name (backend-name backend))
209 (ftd
210 (case name
211 (:darwinx8632
[7775]212 (make-ftd :interface-db-directory "ccl:darwin-x86-headers;"
213 :interface-package-name "X86-DARWIN32"
[6989]214 :attributes '(:bits-per-word 32
215 :signed-char t
216 :struct-by-value t
217 :prepend-underscore t)
218 :ff-call-expand-function
219 (intern "EXPAND-FF-CALL" "X86-DARWIN32")
[7221]220 :ff-call-struct-return-by-implicit-arg-function
[6989]221 (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
222 "X86-DARWIN32")
223 :callback-bindings-function
224 (intern "GENERATE-CALLBACK-BINDINGS" "X86-DARWIN32")
225 :callback-return-value-function
[10755]226 (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-DARWIN32")))
227 (:linuxx8632
228 (make-ftd :interface-db-directory "ccl:x86-headers;"
229 :interface-package-name "X86-LINUX32"
230 :attributes '(:bits-per-word 32
231 :signed-char nil
232 :struct-by-value t
233 :float-results-in-x87 t)
234 :ff-call-expand-function
235 (intern "EXPAND-FF-CALL" "X86-LINUX32")
236 :ff-call-struct-return-by-implicit-arg-function
237 (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
238 "X86-LINUX32")
239 :callback-bindings-function
240 (intern "GENERATE-CALLBACK-BINDINGS" "X86-LINUX32")
241 :callback-return-value-function
[10905]242 (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-LINUX32")))
243 (:win32
244 (make-ftd :interface-db-directory "ccl:win32-headers;"
245 :interface-package-name "WIN32"
246 :attributes '(:bits-per-word 32
247 :signed-char nil
248 :struct-by-value t
249 :float-results-in-x87 t)
250 :ff-call-expand-function
251 (intern "EXPAND-FF-CALL" "WIN32")
252 :ff-call-struct-return-by-implicit-arg-function
253 (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
254 "WIN32")
255 :callback-bindings-function
256 (intern "GENERATE-CALLBACK-BINDINGS" "WIN32")
257 :callback-return-value-function
258 (intern "GENERATE-CALLBACK-RETURN-VALUE" "WIN32")))
[11254]259 (:solarisx8632
260 (make-ftd :interface-db-directory "ccl:solarisx86-headers;"
261 :interface-package-name "X86-SOLARIS32"
262 :attributes '(:bits-per-word 32
263 :signed-char nil
264 :struct-by-value t
265 :float-results-in-x87 t)
266 :ff-call-expand-function
267 (intern "EXPAND-FF-CALL" "X86-SOLARIS32")
268 :ff-call-struct-return-by-implicit-arg-function
269 (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
270 "X86-SOLARIS32")
271 :callback-bindings-function
272 (intern "GENERATE-CALLBACK-BINDINGS" "X86-SOLARIS32")
273 :callback-return-value-function
274 (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-SOLARIS32")))
[11326]275 (:freebsdx8632
276 (make-ftd :interface-db-directory "ccl:freebsd-headers;"
277 :interface-package-name "X86-FREEBSD32"
278 :attributes '(:bits-per-word 32
279 :signed-char nil
280 :struct-by-value t
281 :float-results-in-x87 t)
282 :ff-call-expand-function
283 (intern "EXPAND-FF-CALL" "X86-FREEBSD32")
284 :ff-call-struct-return-by-implicit-arg-function
285 (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
286 "X86-FREEBSD32")
287 :callback-bindings-function
288 (intern "GENERATE-CALLBACK-BINDINGS" "X86-FREEBSD32")
289 :callback-return-value-function
290 (intern "GENERATE-CALLBACK-RETURN-VALUE" "X86-FREEBSD32")))
[10755]291 )))
[6989]292 (install-standard-foreign-types ftd)
293 (use-interface-dir :libc ftd)
294 (setf (backend-target-foreign-type-data backend) ftd))))
295
296#-x8632-target
297(setup-x8632-ftd *x8632-backend*)
298
299(pushnew *x8632-backend* *known-backends* :key #'backend-name)
[7037]300
[11590]301;;; FFI stuff. The vanilla i386 ABI always returns structures as a
302;;; hidden first argument. Some systems (Darwin, FreeBSD) use a
303;;; variant that returns small (<= 64 bit) structures in registers.
[11550]304
[11552]305;;; A returned structure is passed as a hidden first argument.
[11550]306(defun x8632::record-type-returns-structure-as-first-arg (rtype)
307 (declare (ignore rtype))
308 t)
309
310;;; All arguments are passed on the stack.
311(defun x8632::expand-ff-call (callform args
312 &key (arg-coerce #'null-coerce-foreign-arg)
313 (result-coerce #'null-coerce-foreign-result))
314 (let* ((result-type-spec (or (car (last args)) :void))
[11552]315 (struct-by-value-p nil)
316 (result-op nil)
317 (result-temp nil)
[11550]318 (result-form nil))
319 (multiple-value-bind (result-type error)
320 (ignore-errors (parse-foreign-type result-type-spec))
321 (if error
322 (setq result-type-spec :void result-type *void-foreign-type*)
323 (setq args (butlast args)))
324 (collect ((argforms))
325 (when (typep result-type 'foreign-record-type)
[11552]326 (setq result-form (pop args))
327 (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function
328 *target-ftd*) result-type)
329 (progn
330 (setq result-type *void-foreign-type*
331 result-type-spec :void)
332 (argforms :address)
333 (argforms result-form))
334 (progn
335 (ecase (foreign-type-bits result-type)
336 (8 (setq result-type-spec :unsigned-byte
337 result-op '%get-unsigned-byte))
338 (16 (setq result-type-spec :unsigned-halfword
339 result-op '%get-unsigned-word))
340 (32 (setq result-type-spec :unsigned-fullword
341 result-op '%get-unsigned-long))
342 (64 (setq result-type-spec :unsigned-doubleword
343 result-op '%%get-unsigned-longlong)))
344 (setq result-type (parse-foreign-type result-type-spec))
345 (setq result-temp (gensym))
346 (setq struct-by-value-p t))))
[11550]347 (unless (evenp (length args))
348 (error "~s should be an even-length list of alternating foreign types and values" args))
349 (do* ((args args (cddr args)))
350 ((null args))
351 (let* ((arg-type-spec (car args))
352 (arg-value-form (cadr args)))
353 (if (or (member arg-type-spec *foreign-representation-type-keywords*
354 :test #'eq)
355 (typep arg-type-spec 'unsigned-byte))
356 (progn
357 (argforms arg-type-spec)
358 (argforms arg-value-form))
359 (let* ((ftype (parse-foreign-type arg-type-spec))
360 (bits (ensure-foreign-type-bits ftype)))
361 (when (and (typep ftype 'foreign-record-type)
362 (eq (foreign-record-type-kind ftype)
363 :transparent-union))
364 (ensure-foreign-type-bits ftype)
365 (setq ftype (foreign-record-field-type
366 (car (foreign-record-type-fields ftype)))
367 arg-type-spec (foreign-type-to-representation-type
368 ftype)
369 bits (ensure-foreign-type-bits ftype)))
[11552]370 (if (typep ftype 'foreign-record-type)
371 (argforms (ceiling bits 32))
372 (argforms (foreign-type-to-representation-type ftype)))
[11550]373 (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
[11552]374 (argforms (foreign-type-to-representation-type result-type))
375 (let* ((call (funcall result-coerce result-type-spec
376 `(,@callform ,@(argforms)))))
377 (if struct-by-value-p
378 `(let* ((,result-temp (%null-ptr)))
379 (declare (dynamic-extent ,result-temp)
380 (type macptr ,result-temp))
381 (%setf-macptr ,result-temp ,result-form)
382 (setf (,result-op ,result-temp 0)
383 ,call))
384 call))))))
[11550]385
[11552]386;;; Return 8 values:
[11550]387;;; A list of RLET bindings
388;;; A list of LET* bindings
389;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
390;;; A list of initializaton forms for (some) structure args (not used on x8632)
391;;; A FOREIGN-TYPE representing the "actual" return type.
392;;; A form which can be used to initialize FP-ARGS-PTR, relative
[11552]393;;; to STACK-PTR. (not used on x8632)
[11550]394;;; The byte offset of the foreign return address, relative to STACK-PTR
[11552]395;;; The number of argument bytes pushed on the stack by the caller, or NIL
396;;; if this can't be determined. (Only meaningful on Windows.)
[11550]397
398(defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars
[12590]399 argspecs result-spec
400 struct-result-name)
[11550]401 (declare (ignore fp-args-ptr))
402 (collect ((lets)
[11552]403 (rlets)
[11550]404 (dynamic-extent-names))
405 (let* ((rtype (parse-foreign-type result-spec)))
406 (when (typep rtype 'foreign-record-type)
[11552]407 (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function
408 *target-ftd*) rtype)
409 (setq argvars (cons struct-result-name argvars)
410 argspecs (cons :address argspecs)
411 rtype *void-foreign-type*)
412 (rlets (list struct-result-name (foreign-record-type-name rtype)))))
[11550]413 (do* ((argvars argvars (cdr argvars))
414 (argspecs argspecs (cdr argspecs))
415 (offset 8))
416 ((null argvars)
[11552]417 (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 4
418 (- offset 8)))
[11550]419 (let* ((name (car argvars))
420 (spec (car argspecs))
421 (argtype (parse-foreign-type spec))
422 (bits (require-foreign-type-bits argtype))
423 (double nil))
424 (if (typep argtype 'foreign-record-type)
[12590]425 (let* ((form `(%inc-ptr ,stack-ptr
426 ,(prog1 offset
427 (incf offset
428 (* 4 (ceiling bits 32)))))))
429 (when name (lets (list name form))))
430 (let* ((form `(,
431 (ecase (foreign-type-to-representation-type argtype)
432 (:single-float '%get-single-float)
433 (:double-float (setq double t) '%get-double-float)
434 (:signed-doubleword (setq double t)
435 '%%get-signed-longlong)
436 (:signed-fullword '%get-signed-long)
437 (:signed-halfword '%get-signed-word)
438 (:signed-byte '%get-signed-byte)
439 (:unsigned-doubleword (setq double t)
440 '%%get-unsigned-longlong)
441 (:unsigned-fullword '%get-unsigned-long)
442 (:unsigned-halfword '%get-unsigned-word)
443 (:unsigned-byte '%get-unsigned-byte)
444 (:address '%get-ptr))
445 ,stack-ptr
446 ,offset)))
447 (when name (lets (list name form)))
[11550]448 (incf offset 4)
449 (when double (incf offset 4)))))))))
450
451(defun x8632::generate-callback-return-value (stack-ptr fp-args-ptr result
452 return-type struct-return-arg)
[11552]453 (declare (ignore fp-args-ptr))
[11550]454 (unless (eq return-type *void-foreign-type*)
[11552]455 (if (typep return-type 'foreign-record-type)
[11590]456 ;; If the struct result is returned via a hidden argument, the
457 ;; return type would have been mapped to :VOID. On some
458 ;; systems, small (<= 64 bits) structs are returned by value,
459 ;; which we arrange to retrieve here.
[11552]460 (ecase (ensure-foreign-type-bits return-type)
461 (8 `(setf (%get-unsigned-byte ,stack-ptr -8)
462 (%get-unsigned-byte ,struct-return-arg 0)))
463 (16 `(setf (%get-unsigned-word ,stack-ptr -8)
464 (%get-unsigned-word ,struct-return-arg 0)))
465 (32 `(setf (%get-unsigned-long ,stack-ptr -8)
466 (%get-unsigned-long ,struct-return-arg 0)))
467 (64 `(setf (%%get-unsigned-longlong ,stack-ptr -8)
468 (%%get-unsigned-longlong ,struct-return-arg 0))))
469 (let* ((return-type-keyword (foreign-type-to-representation-type
470 return-type)))
[11550]471 (collect ((forms))
472 (forms 'progn)
473 (case return-type-keyword
474 (:single-float
475 (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
476 (:double-float
477 (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
478 (forms
479 `(setf (,
480 (case return-type-keyword
481 (:address '%get-ptr)
482 (:signed-doubleword '%%get-signed-longlong)
483 (:unsigned-doubleword '%%get-unsigned-longlong)
484 (:double-float '%get-double-float)
485 (:single-float '%get-single-float)
486 (:unsigned-fullword '%get-unsigned-long)
487 (t '%get-signed-long)
488 ) ,stack-ptr -8) ,result))
[11552]489 (forms))))))
[11550]490
491
492
[9375]493#+x8632-target
494(require "X8632-VINSNS")
495
496(provide "X8632-BACKEND")
497
Note: See TracBrowser for help on using the repository browser.