source: trunk/source/level-0/X86/X8632/x8632-def.lisp @ 12374

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

New Japanese character encodings cp 932, eucjp from Yoshinori Tahara.
New x8632 large function support (from rme, mostly.)
The latter's a bit hard to bootstrap; new binaries, fasl/image versions
soon.

File size: 23.0 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2006, Clozure Associates and contributors
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
19;;; Use the offsets in a function's self-reference table to replace
20;;; the :self in (movl ($ :self) (% fn)) wih the function's actual
21;;; address.
22(defx8632lapfunction %update-self-references ((fun arg_z))
23  (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0)) ;imm word count
24  (btr ($ 15) (% imm0))
25  (jnc @proceed)
26  (imm-word-count fun imm0 temp0)
27  (subl ($ '2) (% temp0))
28  (jmp @load-offset)
29  @proceed
30  (subl ($ 2) (% imm0))
31  (box-fixnum imm0 temp0)               ;byte offset of first self-ref offset
32  (jmp @load-offset)
33  @loop
34  (movl (% fun) (@ x8632::misc-header-offset (% fun) (% imm0)))
35  (subl ($ '1) (% temp0))
36  @load-offset
37  (movl (@ x8632::misc-data-offset (% fun) (% temp0)) (% imm0))
38  (test (% imm0) (% imm0))
39  (jne @loop)
40  (single-value-return))
41
42(defx8632lapfunction %function-code-words ((fun arg_z))
43  (trap-unless-typecode= fun x8632::subtag-function)
44  (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0))
45  (btr ($ 15) (% imm0))
46  (jnc @proceed)
47  (imm-word-count fun imm0 temp0)
48  (movl (% temp0) (% arg_z))
49  (single-value-return)
50  @proceed
51  (box-fixnum imm0 arg_z)
52  (single-value-return))
53
54(defx8632lapfunction %nth-immediate ((fun arg_y) (n arg_z))
55  (trap-unless-typecode= fun x8632::subtag-function)
56  (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0))
57  (btr ($ 15) (% imm0))
58  (jnc @proceed)
59  (imm-word-count fun imm0 temp0)
60  (unbox-fixnum temp0 imm0)
61  @proceed
62  (lea (@ (% n) (% imm0) 4) (% imm0))
63  (movl (@ x8632::misc-data-offset (% fun) (% imm0)) (% arg_z))
64  (single-value-return))
65
66(defx8632lapfunction %set-nth-immediate ((fun 4) #|(ra 0)|# (n arg_y) (new arg_z))
67  (popl (@ 8 (% esp)))
68  (popl (% temp0))
69  (addl ($ 4) (% esp))
70  (trap-unless-typecode= temp0 x8632::subtag-function)
71  (movzwl (@ x8632::misc-data-offset (% temp0)) (% imm0))
72  (lea (@ (% n) (% imm0) 4) (% arg_y))
73  ;; expects gvector in temp0
74  (jmp-subprim .SPgvset))
75
76(defx8632lapfunction %function-code-byte ((fun arg_y) (pc arg_z))
77  (unbox-fixnum pc imm0)
78  (movzbl (@ (% fun) (% imm0)) (% imm0))
79  (box-fixnum imm0 arg_z)
80  (single-value-return))
81
82(defx8632lapfunction %function-register-usage ((f arg_z))
83  (check-nargs 1)
84  (trap-unless-typecode= f x8632::subtag-function)
85  (movl (% esp) (% temp0))
86  (pushl ($ nil))
87  (pushl ($ nil))
88  (jmp-subprim .SPvalues))
89
90;;; XXX probably should unify these next two with the x8664 versions.
91
92;;; Make a new function, with PROTO's code and the specified immediates.
93;;; IMMEDIATES should contain lfun-bits as the last element.
94(defun %clone-x86-function (proto &rest immediates)
95  (declare (dynamic-extent immediates))
96  (let* ((protov (function-to-function-vector proto))
97         (code-words (%function-code-words proto))
98         (numimms (length immediates))
99         (newv (allocate-typed-vector :function (the fixnum (+ code-words numimms)))))
100    (declare (fixnum code-words numimms))
101    (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift)))
102    #||
103    ;; XXX bootstrapping
104    (setf (ldb (byte 16 0) (uvref newv 0)) (logior #x8000 numimms))
105    ||#
106    (%update-self-references newv)
107    (do* ((k code-words (1+ k))
108          (imms immediates (cdr imms)))
109         ((null imms) (function-vector-to-function newv))
110      (declare (fixnum k) (list imms))
111      (setf (%svref newv k) (car imms)))))
112
113(defun %copy-function (proto &optional target)
114  (let* ((protov (function-to-function-vector proto))
115         (code-words (%function-code-words proto))
116         (total-words (uvsize protov))
117         (newv (if target
118                 (function-to-function-vector target)
119                 (allocate-typed-vector :function total-words))))
120    (declare (fixnum code-words total-words))
121    (when target
122      (unless (and (eql code-words (%function-code-words target))
123                   (eql total-words (uvsize newv)))
124        (error "Wrong size target ~s" target)))
125    (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift)))
126    (loop for k fixnum from code-words below total-words
127      do (setf (%svref newv k) (%svref protov k)))
128    #||
129    (setf (ldb (byte 16 0) (uvref newv 0))
130          (logior #x8000 (- total-words code-words)))
131    ||#
132    (%update-self-references (function-vector-to-function newv))))
133
134(defun replace-function-code (target proto)
135  (let* ((target-words (%function-code-words target))
136         (proto-words (%function-code-words proto)))
137    (declare (fixnum target-words proto-words))
138    (if (= target-words proto-words)
139      (progn
140        (%copy-ivector-to-ivector (function-to-function-vector proto)
141                                  0
142                                  (function-to-function-vector target)
143                                  0
144                                  (the fixnum (ash target-words
145                                                   target::word-shift)))
146        (%update-self-references target)
147        target)
148      (error "Code size mismatch: target = ~s, proto = ~s"
149             target-words proto-words))))
150
151(defx8632lapfunction %get-kernel-global-from-offset ((offset arg_z))
152  (check-nargs 1)
153  (unbox-fixnum offset imm0)
154  (movl (@ (target-nil-value) (% imm0)) (% arg_z))
155  (single-value-return))
156
157(defx8632lapfunction %set-kernel-global-from-offset ((offset arg_y)
158                                                     (new-value arg_z))
159  (check-nargs 2)
160  (unbox-fixnum offset imm0)
161  (movl (% arg_z) (@ (target-nil-value) (% imm0)))
162  (single-value-return))
163
164(defx8632lapfunction %get-kernel-global-ptr-from-offset ((offset arg_y)
165                                                         (ptr arg_z))
166  (check-nargs 2)
167  (unbox-fixnum offset imm0)
168  (movl (@ (target-nil-value) (% imm0)) (% imm0))
169  (movl (% imm0) (@ x8632::macptr.address (% ptr)))
170  (single-value-return))
171
172(defx8632lapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z))
173  (:arglist (fixnum &optional offset))
174  (check-nargs 1 2)
175  (cmpl ($ x8632::fixnumone) (% nargs))
176  (jne @2-args)
177  (movl (% offset) (% fixnum))
178  (xorl (%l offset) (%l offset))
179  @2-args
180  (unbox-fixnum offset imm0)
181  (movl (@ (% fixnum) (% imm0)) (% arg_z))
182  (single-value-return))
183
184(defx8632lapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
185  (:arglist (fixnum &optional offset))
186  (check-nargs 1 2)
187  (cmpl ($ x8632::fixnumone) (% nargs))
188  (jne @2-args)
189  (movl (% offset) (% fixnum))
190  (xorl (%l offset) (%l offset))
191  @2-args
192  (unbox-fixnum offset imm0)
193  (movl (@ (% fixnum) (% imm0)) (% imm0))
194  (jmp-subprim .SPmakeu32))
195
196(defx8632lapfunction %fixnum-set ((fixnum 4) #|(ra 0)|# (offset arg_y) #| &optional |# (new-value arg_z))
197  (:arglist (fixnum offset &optional newval))
198  (check-nargs 2 3)
199  (cmpl ($ '2) (% nargs))
200  (jne @3-args)
201  (movl (% new-value) (% offset))
202  (single-value-return)
203  @3-args
204  (movl (@ fixnum (% esp)) (% temp0))
205  (unbox-fixnum offset imm0)
206  (movl (% new-value) (@ (% temp0) (% imm0)))
207  (single-value-return 3))
208
209
210(defx8632lapfunction %fixnum-set-natural ((fixnum 4) #|(ra 0)|# (offset arg_y) #| &optional |# (new-value arg_z))
211  (:arglist (fixnum offsnet &optional newval))
212  (check-nargs 2 3)
213  (cmpl ($ '2) (% nargs))
214  (jne @3-args)
215  (save-simple-frame)
216  (movl (% offset) (% temp0))
217  (xorl (% offset) (% offset))
218  (jmp @common)
219  @3-args
220  (movl (% ebp) (@ 8 (% esp)))
221  (lea (@ 8 (% esp)) (% ebp))
222  (popl (@ 4 (% ebp)))
223  (popl (% temp0))
224  @common
225  (call-subprim .SPgetu32)              ;puts u32 in imm0
226  (mark-as-imm temp1)
227  (unbox-fixnum offset temp1)
228  (movl (% imm0) (@ (% temp0) (% temp1)))
229  (mark-as-node temp1)
230  (restore-simple-frame)
231  (single-value-return))
232
233
234(defx8632lapfunction %current-frame-ptr ()
235  (check-nargs 0)
236  (movl (% ebp) (% arg_z))
237  (single-value-return))
238
239
240(defx8632lapfunction %current-tsp ()
241  (check-nargs 0)
242  (movl (:rcontext x8632::tcr.save-tsp) (% arg_z))
243  (single-value-return))
244
245
246(defx8632lapfunction %%frame-backlink ((p arg_z))
247  (check-nargs 1)
248  (movl (@ (% arg_z)) (% arg_z))
249  (single-value-return))
250
251;;; Look for "movl $imm32,%fn at the tra;  if present, then $imm32 is
252;;; the address of the function.
253;;;
254;;; That is: #b10111111 <imm32>
255;;;                ^^^^
256;;;   operand size || register number (%fn/%edi)
257
258(defx8632lapfunction %return-address-function ((r arg_z))
259  (extract-fulltag r imm0)
260  (cmpb ($ x8632::fulltag-tra) (% imm0.b))
261  (jne @fail)
262  (cmpb ($ x8632::recover-fn-opcode-byte) (@ (% r)))
263  (jne @fail)
264  (movl (@ x8632::recover-fn-address-offset (% r)) (% arg_z))
265  (single-value-return)
266  @fail
267  (movl ($ (target-nil-value)) (% arg_z))
268  (single-value-return))
269
270(defx8632lapfunction %return-address-offset ((r arg_z))
271  (extract-fulltag r imm0)
272  (cmpb ($ x8632::fulltag-tra) (% imm0.b))
273  (jne @fail)
274  (cmpb ($ x8632::recover-fn-opcode-byte) (@ (% r)))
275  (jne @fail)
276  (movl (@ x8632::recover-fn-address-offset (% r)) (% imm0))
277  (subl (% arg_z) (% imm0))
278  (negl (% imm0))
279  (box-fixnum imm0 arg_z)
280  (single-value-return)
281  @fail
282  (movl ($ (target-nil-value)) (% arg_z))
283  (single-value-return))
284
285;;; It's always been the case that the function associated with a
286;;; frame pointer is the caller of the function that "uses" that frame.
287(defun %cfp-lfun (p)
288  (let* ((ra (%fixnum-ref p x8632::lisp-frame.return-address)))
289    (if (eq ra (%get-kernel-global ret1valaddr))
290      (setq ra (%fixnum-ref p x8632::lisp-frame.xtra)))
291    (values (%return-address-function ra) (%return-address-offset ra))))
292
293(defx8632lapfunction %uvector-data-fixnum ((uv arg_z))
294  (check-nargs 1)
295  (trap-unless-fulltag= arg_z x8632::fulltag-misc)
296  (addl ($ x8632::misc-data-offset) (% arg_z))
297  (single-value-return))
298
299(defx8632lapfunction %catch-top ((tcr arg_z))
300  (check-nargs 1)
301  (movl ($ (target-nil-value)) (% arg_y))
302  (movl (:rcontext x8632::tcr.catch-top) (% arg_z))
303  (testb (%b arg_z) (%b arg_z))
304  (cmovel (% arg_y) (% arg_z))
305  (single-value-return))
306
307(defx8632lapfunction %catch-tsp ((catch arg_z))
308  (check-nargs 1)
309  (lea (@  (- (+ x8632::fulltag-misc
310                 (ash 1 (1+ x8632::word-shift)))) (% arg_z))
311       (% arg_z))
312  (single-value-return))
313
314;;; Same as %address-of, but doesn't cons any bignums
315;;; It also left shift fixnums just like everything else.
316(defx8632lapfunction %fixnum-address-of ((x arg_z))
317  (check-nargs 1)
318  (box-fixnum x arg_z)
319  (single-value-return))
320
321(defx8632lapfunction %save-standard-binding-list ((bindings arg_z))
322  (mark-as-imm temp0)
323  (movl (:rcontext x8632::tcr.vs-area) (% imm0))
324  (movl (@ x8632::area.high (% imm0)) (% temp0))
325  (subl ($ x8632::node-size) (% temp0))
326  (movl (% bindings) (@ (% temp0)))
327  (mark-as-node temp0)
328  (single-value-return))
329
330(defx8632lapfunction %saved-bindings-address ()
331  (mark-as-imm temp0)
332  (movl (:rcontext x8632::tcr.vs-area) (% imm0))
333  (movl (@ x8632::area.high (% imm0)) (% temp0))
334  (leal (@ (- x8632::node-size) (% temp0)) (% arg_z))
335  (mark-as-node temp0)
336  (single-value-return))
337
338(defx8632lapfunction %get-object ((macptr arg_y) (offset arg_z))
339  (check-nargs 2)
340  (trap-unless-typecode= macptr x8632::subtag-macptr)
341  (trap-unless-lisptag= offset x8632::tag-fixnum)
342  (macptr-ptr macptr imm0)
343  (mark-as-imm temp0)
344  (unbox-fixnum offset temp0)
345  (movl (@ (% imm0) (% temp0)) (% arg_z))
346  (mark-as-node temp0)
347  (single-value-return))
348
349(defx8632lapfunction %set-object ((macptr 4) #|(ra 0)|# (offset arg_y) (value arg_z))
350  (check-nargs 3)
351  (movl (@ macptr (% esp)) (% temp1))
352  (trap-unless-typecode= temp1 x8632::subtag-macptr)
353  (trap-unless-lisptag= offset x8632::tag-fixnum)
354  (macptr-ptr temp1 imm0)
355  (mark-as-imm temp0)
356  (unbox-fixnum offset temp0)
357  (movl (% arg_z) (@ (% imm0) (% temp0)))
358  (mark-as-node temp0)
359  (single-value-return 3))
360
361(defx8632lapfunction %apply-lexpr-with-method-context ((magic 4)
362                                                       #|(ra 0)|#
363                                                       (function arg_y)
364                                                       (args arg_z))
365  ;; Somebody's called (or tail-called) us.
366  ;; * Put magic arg in %rcontext:tcr.next-method-context
367  ;; * Put function somewhere safe until we're ready to jump to it
368  ;; * Set nargs to 0, then spread "args" on stack (clobbers regs)
369  ;; * Jump to function (saved previously)
370  (popl (:rcontext x8632::tcr.save0))   ;return address
371  (popl (:rcontext x8632::tcr.next-method-context)) ;magic arg
372  (discard-reserved-frame)
373  (movl (% function) (:rcontext x8632::tcr.save1))
374  (set-nargs 0)
375  (movl (@ (% args)) (% temp0))         ;lexpr-count
376  (movl (% temp0) (% nargs))
377  (leal (@ x8632::node-size (% arg_z) (% temp0)) (% imm0))
378  (subl ($ '2) (% temp0))
379  (jbe @reg-only)
380  ;; Some args will be pushed; reserve a frame.
381  (pushl ($ x8632::reserved-frame-marker))
382  (pushl ($ x8632::reserved-frame-marker))
383  @pushloop
384  (pushl (@ (- x8632::node-size) (% imm0)))
385  (subl ($ x8632::node-size) (% imm0))
386  (subl ($ x8632::node-size) (% temp0))
387  (jne @pushloop)
388  @two
389  (movl (@ (* x8632::node-size 2) (% arg_z)) (% arg_y))
390  @one
391  (movl (@ (* x8632::node-size 1) (% arg_z)) (% arg_z))
392  (jmp @go)
393  @reg-only
394  (rcmp (% nargs) ($ '1))
395  (je @one)
396  (jb @go)
397  (jmp @two)
398  @go
399  (pushl (:rcontext x8632::tcr.save0))   ;return address
400  (movl (:rcontext x8632::tcr.save1) (% temp0)) ;function
401  (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear spill area
402  (jmp (% temp0)))
403
404(defx8632lapfunction %apply-with-method-context ((magic 4)
405                                                 #|(ra 0)|#
406                                                 (function arg_y)
407                                                 (args arg_z))
408  ;; Similar to above.
409  (popl (:rcontext x8632::tcr.save0))   ;save return address
410  (popl (:rcontext x8632::tcr.next-method-context))     ;
411  (discard-reserved-frame)
412  (movl (% args) (:rcontext x8632::tcr.save2))  ;in case of error
413  (set-nargs 0)
414  (pushl ($ target::reserved-frame-marker))             ;reserve frame (might discard it
415  (pushl ($ target::reserved-frame-marker))             ;if nothing is passed on stack)
416  (cmp-reg-to-nil arg_z)
417  (je @done)
418  @loop
419  (extract-fulltag arg_z imm0)
420  (cmpb ($ x8632::fulltag-cons) (% imm0.b)) ;nil is a cons on x8632, but we
421  (jne @bad)                                 ; checked for it already.
422  (add ($ '1) (% nargs))                        ;shorter than lea (imm0 is eax)
423  (pushl (@ target::cons.car (% arg_z)))
424  (%cdr arg_z arg_z)
425  (cmp-reg-to-nil arg_z)
426  (jne @loop)
427  @done
428  ;; arg_y about to get clobbered; put function into temp0
429  (movl (% function) (% temp0))
430  ;; temp1 (aka nargs) contains number of args just pushed
431  (test (% nargs) (% nargs))
432  (jne @pop)
433  @discard-and-go
434  (discard-reserved-frame)
435  (jmp @go)
436  @pop
437  (cmpl ($ '1) (% nargs))
438  (pop (% arg_z))
439  (je @discard-and-go)
440  (cmpl ($ '2) (% nargs))
441  (pop (% arg_y))
442  (je @discard-and-go)
443  @go
444  (pushl (:rcontext x8632::tcr.save0))   ;return address
445  (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area
446  (jmp (% temp0))
447  @bad
448  (addl (% nargs) (% esp))
449  (movl (:rcontext x8632::tcr.save1) (% arg_z)) ;saved args
450  (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area
451  (movl ($ '#.$XNOSPREAD) (% arg_y))
452  (set-nargs 2)
453  (jmp-subprim .SPksignalerr))
454
455;;; The idea here is to call METHOD in the same stack frame in
456;;; which the lexpr was originally called.  The lexpr can't
457;;; have had any required arguments, %APPLY-LEXPR-TAIL-WISE
458;;; must have been tail-called, and the frame built on lexpr
459;;; entry must be in %rbp.
460(defx8632lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
461  (addl ($ x8632::node-size) (% esp))   ; discard extra return address
462  (movl (% method) (% xfn))             ;temp1
463  (movl (% args) (% esp))
464  (popl (% imm0))                       ;nargs
465  (movl (@ x8632::lisp-frame.return-address (% ebp)) (% temp0))
466  (movl (@ 0 (% ebp)) (% ebp))
467  (rcmpl (% imm0) ($ '2))
468  (jbe @pop-regs)
469  ;; More than 2 args; some must have been pushed by caller,
470  ;; so retain the reserved frame.
471  (pop (% arg_z))
472  (pop (% arg_y))
473  (jmp @popped)
474  @pop-regs
475  (rcmpl (% imm0) ($ '1))
476  (jb @discard)
477  (ja @pop2)
478  (pop (% arg_z))
479  (jmp @discard)
480  @pop2
481  (pop (% arg_z))
482  (pop (% arg_y))
483  @discard
484  (discard-reserved-frame)
485  @popped
486  (push (% temp0))                      ;return address
487  (movl (% xfn) (% temp0))              ;temp1 is also nargs
488  (movl (% imm0) (% nargs))
489  (jmp (% temp0)))
490
491(defun closure-function (fun)
492  (while (and (functionp fun) (not (compiled-function-p fun)))
493    (setq fun (%nth-immediate fun 0))
494    (when (vectorp fun)
495      (setq fun (svref fun 0))))
496  fun)
497
498;;; For use by (setf (apply ...) ...)
499;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
500
501(defun apply+ (&lap function arg1 arg2 &rest other-args)
502  (x86-lap-function apply+ ()
503   (:arglist (function arg1 arg2 &rest other-args))
504   (check-nargs 3 nil)
505   (popl (:rcontext x8632::tcr.save0))  ;save return address
506   ;; only two arg regs on x8632, so the caller will always push a frame
507   (movl (% arg_z) (% temp0))           ; last
508   (movl (% arg_y) (% arg_z))           ; butlast
509   (subl ($ '2) (% nargs))              ; remove count for butlast & last
510   (movd (% temp1) (% mm0))             ;save nargs (aka temp1) for later
511   ;; Do .SPspreadargz inline here
512   (xorl (%l temp1) (%l temp1))
513   (movl (% arg_z) (:rcontext x8632::tcr.save1)) ; save in case of error
514   (cmp-reg-to-nil arg_z)
515   (je @done)
516   ;;(mark-as-imm temp1)
517   @loop
518   (extract-fulltag arg_z imm0)
519   (cmpb ($ x8632::fulltag-cons) (%b imm0))
520   (jne @bad)
521   (%car arg_z arg_y)
522   (%cdr arg_z arg_z)
523   (addl ($ '1) (%l temp1))
524   (cmp-reg-to-nil arg_z)   
525   (push (% arg_y))
526   (jne @loop)
527   @done
528   ;; nargs was at least 1 when we started spreading, and can't have gotten
529   ;; any smaller.
530   (movd (% mm0) (% arg_y))             ;nargs from before loop
531   (addl (% arg_y) (% temp1))           ;did I mention nargs is temp1?
532   (movl (% temp0) (% arg_z))
533   (pop (% arg_y))
534   (addl ($ '1) (% nargs))
535   (load-constant funcall temp0)
536   (pushl (:rcontext x8632::tcr.save0)) ;return address
537   (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area
538   (jmp-subprim .SPfuncall)
539   @bad                               ;error spreading list.
540   (add (% temp1) (% esp))            ;discard whatever's been pushed
541   (movl (:rcontext x8632::tcr.save1) (% arg_z))
542   (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area
543   (movl ($ '#.$XNOSPREAD) (% arg_y))
544   (set-nargs 2)
545   (jmp-subprim .SPksignalerr) ))
546
547
548
549;;; This needs to:
550;;; (a) call the .SPffcall subprimitive, which will discard the foreign
551;;;     stack frame allocated by WITH-VARIABLE-C-FRAME in %FF-CALL
552;;; (b) re-establish the same foreign stack frame and store the results
553;;;     there.
554;;;
555;;; The flags argument tells us what/where the result is:
556;;;
557;;;; flags   meaning
558;;;    0     32-bit value in EAX
559;;;    1     single-float value on x87 stack
560;;;    2     double-float value on x87 stack
561;;;    3     64-bit value with low half in EAX, high half in tcr.unboxed1
562
563(defx8632lapfunction %do-ff-call ((flags 4) #|(ra 0)|# (frame arg_y) (entry arg_z))
564  (save-stackargs-frame 1)
565  (push (% arg_y))
566  (push (% arg_z))
567  (call-subprim .SPffcall)
568  ;; there might be an fp result on x87 stack, so don't use
569  ;; any mmx instructions until the result has been read.
570  (movd (:rcontext x8632::tcr.foreign-sp) (% xmm0))
571  (movd (% xmm0) (@ (% frame)))
572  (movl (% frame) (:rcontext x8632::tcr.foreign-sp))
573  (cmpl ($ 0) (@ -4 (% ebp)))
574  (jne @fp-or-doubleword)
575  (movl (% eax) (@ 4 (% frame)))
576  @done
577  (movl ($ nil) (% arg_z))
578  (restore-simple-frame)
579  (single-value-return)
580  @fp-or-doubleword
581  (cmpl ($ '2) (@ -4 (% ebp)))
582  (jl @single)
583  (je @double)
584  ;; high 32 bits in tcr.unboxed1 (see .SPffcall)
585  (movl (% eax) (@ 4 (% frame)))
586  (movl (:rcontext x8632::tcr.unboxed1) (% eax))
587  (movl (% eax) (@ 8 (% frame)))
588  (jmp @done)
589  @single
590  (fstps (@ 4 (% frame)))
591  (jmp @done)
592  @double
593  (fstpl (@ 4 (% frame)))
594  (jmp @done))
595
596(defun %ff-call (entry &rest specs-and-vals)
597  (declare (dynamic-extent specs-and-vals))
598  (let* ((len (length specs-and-vals))
599         (total-words 0))
600    (declare (fixnum len total-words))
601    (let* ((result-spec (or (car (last specs-and-vals)) :void))
602           (nargs (ash (the fixnum (1- len)) -1)))
603      (declare (fixnum nargs))
604      (ecase result-spec
605        ((:address :unsigned-doubleword :signed-doubleword
606                   :single-float :double-float
607                   :signed-fullword :unsigned-fullword
608                   :signed-halfword :unsigned-halfword
609                   :signed-byte :unsigned-byte
610                   :void)
611         (do* ((i 0 (1+ i))
612               (specs specs-and-vals (cddr specs))
613               (spec (car specs) (car specs)))
614              ((= i nargs))
615           (declare (fixnum i))
616           (case spec
617             (:registers
618              (error "don't know what to do with argspec ~s" spec))
619             ((:double-float :unsigned-doubleword :signed-doubleword)
620              (incf total-words 2))
621             ((:address :single-float
622                        :signed-fullword :unsigned-fullword
623                        :signed-halfword :unsigned-halfword
624                        :signed-byte :unsigned-byte)
625              (incf total-words))
626             (t (if (typep spec 'unsigned-byte)
627                  (incf total-words spec)
628                  (error "Invalid argument spec ~s" spec)))))
629         ;; It's necessary to ensure that the C frame is the youngest thing on
630         ;; the foreign stack here.
631         (with-macptrs ((argptr))
632           (with-variable-c-frame
633               total-words frame
634               (%setf-macptr-to-object argptr frame)
635               (let* ((offset 8))
636                 (do* ((i 0 (1+ i))
637                       (specs specs-and-vals (cddr specs))
638                       (spec (car specs) (car specs))
639                       (val (cadr specs) (cadr specs)))
640                      ((= i nargs))
641                   (declare (fixnum i))
642                   (case spec
643                     (:double-float
644                      (setf (%get-double-float argptr offset) val)
645                      (incf offset 8))
646                     (:single-float
647                      (setf (%get-single-float argptr offset) val)
648                      (incf offset 4))
649                     (:signed-doubleword
650                      (setf (%%get-signed-longlong argptr offset) val)
651                      (incf offset 8))
652                     (:unsigned-doubleword
653                      (setf (%%get-unsigned-longlong argptr offset) val)
654                      (incf offset 8))
655                     (:address
656                      (setf (%get-ptr argptr offset) val)
657                      (incf offset 4))
658                     ((:signed-fullword :signed-halfword :signed-byte)
659                      (setf (%get-signed-natural argptr offset) val)
660                      (incf offset 4))
661                     ((:unsigned-fullword :unsigned-halfword :unsigned-byte)
662                      (setf (%get-natural argptr offset) val)
663                      (incf offset 4))
664                     (t
665                      (let* ((p 0))
666                        (declare (fixnum p))
667                        (dotimes (i (the fixnum spec))
668                          (setf (%get-ptr argptr offset) (%get-ptr val p))
669                          (incf p 4)
670                          (incf offset 4))))))
671                 (let ((flags (case result-spec
672                                (:single-float 1)
673                                (:double-float 2)
674                                ((:signed-doubleword :unsigned-doubleword) 3)
675                                (t 0))))
676                   (%do-ff-call flags frame entry))
677                 (ecase result-spec
678                   (:void nil)
679                   (:address (%get-ptr argptr 4))
680                   (:unsigned-byte (%get-unsigned-byte argptr 4))
681                   (:signed-byte (%get-signed-byte argptr 4))
682                   (:unsigned-halfword (%get-unsigned-word argptr 4))
683                   (:signed-halfword (%get-signed-word argptr 4))
684                   (:unsigned-fullword (%get-natural argptr 4))
685                   (:signed-fullword (%get-signed-natural argptr 4))
686                   (:unsigned-doubleword (%%get-unsigned-longlong argptr 4))
687                   (:signed-doubleword (%%get-signed-longlong argptr 4))
688                   (:single-float (%get-single-float argptr 4))
689                   (:double-float (%get-double-float argptr 4)))))))))))
690
691;;; end of x86-def.lisp
Note: See TracBrowser for help on using the repository browser.