source: trunk/source/level-0/X86/x86-misc.lisp @ 16323

Last change on this file since 16323 was 16323, checked in by gb, 6 years ago

Try to make STATIC-CONS thread-safe with respect to the GC by:

-exploiting the fact that *KERNEL-EXCEPTION-LOCK* is a real lisp-visible
lock object and define WITH-EXCEPTION-LOCK in terms of it

  • use WITH-EXCEPTION-LOCK in #'STATIC-CONS
  • drop the old %ATOMIC-POP-STATIC-CONS on all platforms.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 45.9 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;;; level-0;x86;x86-misc.lisp
19
20
21(in-package "CCL")
22#+x8664-target
23(progn
24
25;;; Copy N bytes from pointer src, starting at byte offset src-offset,
26;;; to ivector dest, starting at offset dest-offset.
27;;; It's fine to leave this in lap.
28;;; Depending on alignment, it might make sense to move more than
29;;; a byte at a time.
30;;; Does no arg checking of any kind.  Really.
31
32(defx86lapfunction %copy-ptr-to-ivector ((src (* 2 x8664::node-size) )
33                                         (src-byte-offset (* 1 x8664::node-size))
34                                         #|(ra 0)|#
35                                         (dest arg_x)
36                                         (dest-byte-offset arg_y)
37                                         (nbytes arg_z))
38  (let ((rsrc temp0)
39        (rsrc-byte-offset temp1))
40    (testq (% nbytes) (% nbytes))
41    (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset))         ; boxed src-byte-offset
42    (movq (@ src (% rsp)) (% rsrc))     ; src macptr
43    (jmp @test)
44    @loop
45    (unbox-fixnum rsrc-byte-offset imm0)
46    (addq ($ '1) (% rsrc-byte-offset))
47    (addq (@ x8664::macptr.address (% rsrc)) (% imm0))
48    (movb (@ (% imm0)) (%b imm0))
49    (unbox-fixnum dest-byte-offset imm1)
50    (addq ($ '1) (% dest-byte-offset))
51    (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1)))
52    (subq ($ '1) (% nbytes))
53    @test
54    (jne @loop)
55    (movq (% dest) (% arg_z))
56    (single-value-return 4)))
57
58(defx86lapfunction %copy-ivector-to-ptr ((src (* 2 x8664::node-size))
59                                         (src-byte-offset (* 1 x8664::node-size))
60                                         #|(ra 0)|#
61                                         (dest arg_x)
62                                         (dest-byte-offset arg_y)
63                                         (nbytes arg_z))
64  (let ((rsrc temp0)
65        (rsrc-byte-offset imm0)
66        (rdestptr imm1)
67        (rdata imm2))
68    (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset))
69    (sarq ($ x8664::word-shift) (% rsrc-byte-offset))
70    (movq (% dest-byte-offset) (% rdestptr))
71    (sarq ($ x8664::word-shift) (% rdestptr))
72    (addq (@ target::macptr.address (% dest)) (% rdestptr))
73    (movq (@ src (% rsp)) (% rsrc))
74    (testq (% nbytes) (% nbytes))
75    (jmp @test)
76    @loop
77    (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b rdata))
78    (addq ($ 1) (% rsrc-byte-offset))
79    (movb (%b rdata) (@ (% rdestptr)))
80    (addq ($ 1) (% rdestptr))
81    (subq ($ '1) (% nbytes))
82    @test
83    (jne @loop)
84    (movq (% dest) (% arg_z))
85    (single-value-return 4)))
86
87
88(defun %copy-ivector-to-ivector (src src-byte-offset dest dest-byte-offset nbytes)
89  (declare (fixnum src-byte-offset dest-byte-offset nbytes))
90  (if (or (not (eq src dest))
91          (< dest-byte-offset src-byte-offset)
92          (>= dest-byte-offset (the fixnum (+ src-byte-offset nbytes))))
93    (%copy-ivector-to-ivector-postincrement src src-byte-offset dest dest-byte-offset nbytes)
94    (if (and (eq src dest)
95             (eql src-byte-offset dest-byte-offset))
96      dest
97      (%copy-ivector-to-ivector-predecrement src
98                                             (the fixnum (+ src-byte-offset nbytes))
99                                             dest
100                                             (the fixnum (+ dest-byte-offset nbytes))
101                                             nbytes)))
102  dest)
103
104(defun %copy-ivector-to-ivector-postincrement (src src-byte-offset dest dest-byte-offset nbytes)
105  (declare (fixnum src-byte-offset dest-byte-offset nbytes))
106 
107  (cond ((or (< nbytes 8)
108             (not (= (logand src-byte-offset 3)
109                     (logand dest-byte-offset 3))))
110         (%copy-ivector-to-ivector-postincrement-8bit src src-byte-offset dest dest-byte-offset nbytes))
111        ((and (>= nbytes 80)
112              (= (logand src-byte-offset 15)
113                 (logand dest-byte-offset 15)))
114         (let* ((prefix-size (- 16 (logand (the fixnum (+ src-byte-offset 8)) 15))))
115           (declare (fixnum prefix-size))
116           (unless (= 16 prefix-size)
117             (%copy-ivector-to-ivector-postincrement-8bit src src-byte-offset dest dest-byte-offset prefix-size)
118             (incf src-byte-offset prefix-size)
119             (incf dest-byte-offset prefix-size)
120             (decf nbytes prefix-size)))
121         (let* ((tail-size (logand nbytes 15))
122                (dqsize (- nbytes tail-size)))
123           (declare (fixnum tail-size dqsize))
124           (%copy-ivector-to-ivector-postincrement-128bit src src-byte-offset dest dest-byte-offset dqsize)
125           (unless (zerop tail-size)
126             (%copy-ivector-to-ivector-postincrement-8bit src (the fixnum (+ src-byte-offset dqsize)) dest (the fixnum (+ dest-byte-offset dqsize)) tail-size))))
127        ((= (logand src-byte-offset 7) (logand dest-byte-offset 7))
128         (let* ((prefix-size (- 8 (logand src-byte-offset 7))))
129           (declare (fixnum prefix-size))
130           (unless (= 8 prefix-size)
131             (%copy-ivector-to-ivector-postincrement-8bit src src-byte-offset dest dest-byte-offset prefix-size)
132             (incf src-byte-offset prefix-size)
133             (incf dest-byte-offset prefix-size)
134             (decf nbytes prefix-size)))
135         (let* ((tail-size (logand nbytes 7))
136                (fullword-size (- nbytes tail-size)))
137           (declare (fixnum tail-size fullword-size))
138           (unless (zerop fullword-size)
139             (%copy-ivector-to-ivector-postincrement-64bit src src-byte-offset dest dest-byte-offset fullword-size))
140           (unless (zerop tail-size)
141             (%copy-ivector-to-ivector-postincrement-8bit src (the fixnum (+ src-byte-offset fullword-size)) dest (the fixnum (+ dest-byte-offset fullword-size)) tail-size))))
142        (t
143         (let* ((prefix-size (- 4 (logand src-byte-offset 3))))
144           (declare (fixnum prefix-size))
145           (unless (= 4 prefix-size)
146             (%copy-ivector-to-ivector-postincrement-8bit src src-byte-offset dest dest-byte-offset prefix-size)
147             (incf src-byte-offset prefix-size)
148             (incf dest-byte-offset prefix-size)
149             (decf nbytes prefix-size)))
150         (let* ((tail-size (logand nbytes 3))
151                (fullword-size (- nbytes tail-size)))
152           (declare (fixnum tail-size fullword-size))
153           (unless (zerop fullword-size)
154             (%copy-ivector-to-ivector-postincrement-32bit src src-byte-offset dest dest-byte-offset fullword-size))
155           (unless (zerop tail-size)
156             (%copy-ivector-to-ivector-postincrement-8bit src (the fixnum (+ src-byte-offset fullword-size)) dest (the fixnum (+ dest-byte-offset fullword-size)) tail-size))))))
157
158(defun %copy-ivector-to-ivector-predecrement (src src-byte-offset dest dest-byte-offset nbytes)
159  (declare (fixnum src-byte-offset dest-byte-offset nbytes))
160  (cond ((or (< nbytes 8)
161             (not (= (logand src-byte-offset 3)
162                     (logand dest-byte-offset 3))))
163         (%copy-ivector-to-ivector-predecrement-8bit src src-byte-offset dest dest-byte-offset nbytes))
164        ((and (>= nbytes 80)
165              (= (logand src-byte-offset 15)
166                 (logand dest-byte-offset 15)))
167      (let* ((suffix-size (logand src-byte-offset 15)))
168        (declare (fixnum suffix-size))
169        (unless (zerop suffix-size)
170          (%copy-ivector-to-ivector-predecrement-8bit src src-byte-offset dest dest-byte-offset suffix-size)
171          (decf src-byte-offset suffix-size)
172          (decf dest-byte-offset suffix-size)
173          (decf nbytes suffix-size)))
174      (let* ((head-size (logand nbytes 15))
175             (fullword-size (- nbytes head-size)))
176        (declare (fixnum head-size fullword-size))
177        (unless (zerop fullword-size)
178          (%copy-ivector-to-ivector-predecrement-128bit src src-byte-offset dest dest-byte-offset fullword-size))
179        (unless (zerop head-size)
180          (%copy-ivector-to-ivector-predecrement-8bit src (the fixnum (- src-byte-offset fullword-size)) dest (the fixnum (- dest-byte-offset fullword-size)) head-size))))
181    ((= (logand src-byte-offset 7) (logand dest-byte-offset 7))
182      (let* ((suffix-size (logand src-byte-offset 7)))
183        (declare (fixnum suffix-size))
184        (unless (zerop suffix-size)
185          (%copy-ivector-to-ivector-predecrement-8bit src src-byte-offset dest dest-byte-offset suffix-size)
186          (decf src-byte-offset suffix-size)
187          (decf dest-byte-offset suffix-size)
188          (decf nbytes suffix-size)))
189      (let* ((head-size (logand nbytes 7))
190             (fullword-size (- nbytes head-size)))
191        (declare (fixnum head-size fullword-size))
192        (unless (zerop fullword-size)
193          (%copy-ivector-to-ivector-predecrement-64bit src src-byte-offset dest dest-byte-offset fullword-size))
194        (unless (zerop head-size)
195          (%copy-ivector-to-ivector-predecrement-8bit src (the fixnum (- src-byte-offset fullword-size)) dest (the fixnum (- dest-byte-offset fullword-size)) head-size))))
196    (t
197      (let* ((suffix-size (logand src-byte-offset 3)))
198        (declare (fixnum suffix-size))
199        (unless (zerop suffix-size)
200          (%copy-ivector-to-ivector-predecrement-8bit src src-byte-offset dest dest-byte-offset suffix-size)
201          (decf src-byte-offset suffix-size)
202          (decf dest-byte-offset suffix-size)
203          (decf nbytes suffix-size)))
204      (let* ((head-size (logand nbytes 3))
205             (fullword-size (- nbytes head-size)))
206        (declare (fixnum head-size fullword-size))
207        (unless (zerop fullword-size)
208          (%copy-ivector-to-ivector-predecrement-32bit src src-byte-offset dest dest-byte-offset fullword-size))
209        (unless (zerop head-size)
210          (%copy-ivector-to-ivector-predecrement-8bit src (the fixnum (- src-byte-offset fullword-size)) dest (the fixnum (- dest-byte-offset fullword-size)) head-size))))))
211
212(defx86lapfunction %copy-ivector-to-ivector-postincrement-8bit ((src 16) (src-byte-offset 8) #||(ra 0)||# (dest arg_x) (dest-byte-offset arg_y) (nbytes arg_z))
213  (let ((rsrc temp0)
214        (srcidx imm0)
215        (destidx imm1)
216        (data imm2))
217    (movq (@ src (% rsp)) (% rsrc))
218    (movq (@ src-byte-offset (% rsp)) (% srcidx))
219    (sarq ($ target::fixnumshift) (% srcidx))
220    (movq (% dest-byte-offset) (% destidx))
221    (sarq ($ target::fixnumshift) (% destidx))
222    (jmp @test)
223    @loop
224    (movzbl (@ target::misc-data-offset (% rsrc) (% srcidx)) (%l data))
225    (movb (%b data) (@ target::misc-data-offset (% dest) (% destidx)))
226    (lea (@ 1 (% destidx)) (% destidx))
227    (lea (@ 1 (% srcidx)) (% srcidx))
228    @test
229    (subq ($ '1) (% nbytes))
230    (jge @loop)
231    (movq (% dest) (% arg_z))
232    (single-value-return 4)))
233
234
235
236(defx86lapfunction %copy-ivector-to-ivector-predecrement-8bit ((src 16) (src-byte-offset 8) #||(ra 0)||# (dest arg_x) (dest-byte-offset arg_y) (nbytes arg_z))
237  (let ((rsrc temp0)
238        (srcidx imm0)
239        (destidx imm1)
240        (data imm2))
241    (movq (@ src (% rsp)) (% rsrc))
242    (movq (@ src-byte-offset (% rsp)) (% srcidx))
243    (sarq ($ target::fixnumshift) (% srcidx))
244    (movq (% dest-byte-offset) (% destidx))
245    (sarq ($ target::fixnumshift) (% destidx))
246    (jmp @test)
247    @loop
248    (lea (@ -1 (% destidx)) (% destidx))
249    (lea (@ -1 (% srcidx)) (% srcidx))
250    (movzbl (@ target::misc-data-offset (% rsrc) (% srcidx)) (%l data))
251    (movb (%b data) (@ target::misc-data-offset (% dest) (% destidx)))
252    @test
253    (subq ($ '1) (% nbytes))
254    (jge @loop)
255    (movq (% dest) (% arg_z))
256    (single-value-return 4)))
257
258
259(defx86lapfunction %copy-ivector-to-ivector-postincrement-32bit ((src 16) (src-byte-offset 8) #||(ra 0)||# (dest arg_x) (dest-byte-offset arg_y) (nbytes arg_z))
260  (let ((rsrc temp0)
261        (srcidx imm0)
262        (destidx imm1)
263        (data imm2))
264    (movq (@ src (% rsp)) (% rsrc))
265    (movq (@ src-byte-offset (% rsp)) (% srcidx))
266    (sarq ($ target::fixnumshift) (% srcidx))
267    (movq (% dest-byte-offset) (% destidx))
268    (sarq ($ target::fixnumshift) (% destidx))
269    (jmp @test)
270    @loop
271    (movl (@ target::misc-data-offset (% rsrc) (% srcidx)) (%l data))
272    (movl (%l data) (@ target::misc-data-offset (% dest) (% destidx)))
273    (lea (@ 4 (% destidx)) (% destidx))
274    (lea (@ 4 (% srcidx)) (% srcidx))
275    @test
276    (subq ($ '4) (% nbytes))
277    (jge @loop)
278    (movq (% dest) (% arg_z))
279    (single-value-return 4)))
280
281(defx86lapfunction %copy-ivector-to-ivector-predecrement-32bit ((src 16) (src-byte-offset 8) #||(ra 0)||# (dest arg_x) (dest-byte-offset arg_y) (nbytes arg_z))
282  (let ((rsrc temp0)
283        (srcidx imm0)
284        (destidx imm1)
285        (data imm2))
286    (movq (@ src (% rsp)) (% rsrc))
287    (movq (@ src-byte-offset (% rsp)) (% srcidx))
288    (sarq ($ target::fixnumshift) (% srcidx))
289    (movq (% dest-byte-offset) (% destidx))
290    (sarq ($ target::fixnumshift) (% destidx))
291    (jmp @test)
292    @loop
293    (lea (@ -4 (% destidx)) (% destidx))
294    (lea (@ -4 (% srcidx)) (% srcidx))
295    (movl (@ target::misc-data-offset (% rsrc) (% srcidx)) (%l data))
296    (movl (%l data) (@ target::misc-data-offset (% dest) (% destidx)))
297    @test
298    (subq ($ '4) (% nbytes))
299    (jge @loop)
300    (movq (% dest) (% arg_z))
301    (single-value-return 4)))
302
303(defx86lapfunction %copy-ivector-to-ivector-postincrement-64bit ((src 16) (src-byte-offset 8) #||(ra 0)||# (dest arg_x) (dest-byte-offset arg_y) (nbytes arg_z))
304  (let ((rsrc temp0)
305        (srcidx temp1)
306        (destidx dest-byte-offset)
307        (data0 imm0)
308        (data1 imm1))
309    (movq (@ src (% rsp)) (% rsrc))
310    (movq (@ src-byte-offset (% rsp)) (% srcidx))
311    ;; srcidx and destidx are multiples of 8, so it's safe to right-shift
312    ;; them here (they remain fixnums).
313    (sarq ($ target::word-shift) (% srcidx))
314    (sarq ($ target::word-shift) (% destidx))
315    (testq ($ '8) (% nbytes))
316    (jz @test)
317    (movq (@ target::misc-data-offset (% rsrc) (% srcidx)) (% data0))
318    (movq (% data0) (@ target::misc-data-offset (% dest) (% destidx)))
319    (lea (@ 8 (% destidx)) (% destidx))
320    (lea (@ 8 (% srcidx)) (% srcidx))
321    (subq ($ '8) (% nbytes))   
322    (jmp @test)
323    @loop
324    (movq (@ target::misc-data-offset (% rsrc) (% srcidx)) (% data0))
325    (movq (@ (+ 8 target::misc-data-offset) (% rsrc) (% srcidx)) (% data1))
326    (movq (% data0) (@ target::misc-data-offset (% dest) (% destidx)))
327    (movq (% data1) (@ (+ 8 target::misc-data-offset) (% dest) (% destidx)))
328    (lea (@ 16 (% destidx)) (% destidx))
329    (lea (@ 16 (% srcidx)) (% srcidx))
330    @test
331    (subq ($ '16) (% nbytes))
332    (jge @loop)
333    (movq (% dest) (% arg_z))
334    (single-value-return 4)))
335
336(defx86lapfunction %copy-ivector-to-ivector-predecrement-64bit ((src 16) (src-byte-offset 8) #||(ra 0)||# (dest arg_x) (dest-byte-offset arg_y) (nbytes arg_z))
337  (let ((rsrc temp0)
338        (srcidx temp1)
339        (destidx dest-byte-offset)
340        (data0 imm0)
341        (data1 imm1))
342    (movq (@ src (% rsp)) (% rsrc))
343    (movq (@ src-byte-offset (% rsp)) (% srcidx))
344    ;; srcidx and destidx are multiples of 8, so it's safe to right-shift
345    ;; them here (they remain fixnums).
346    (sarq ($ target::word-shift) (% srcidx))
347    (sarq ($ target::word-shift) (% destidx))
348    (testq ($ '8) (% nbytes))
349    (jz @test)
350    (lea (@ -8 (% destidx)) (% destidx))
351    (lea (@ -8 (% srcidx)) (% srcidx))
352    (movq (@ target::misc-data-offset (% rsrc) (% srcidx)) (% data0))
353    (movq (% data0) (@ target::misc-data-offset (% dest) (% destidx)))
354    (subq ($ '8) (% nbytes))   
355    (jmp @test)
356    @loop
357    (lea (@ -16 (% destidx)) (% destidx))
358    (lea (@ -16 (% srcidx)) (% srcidx))
359    (movq (@ target::misc-data-offset (% rsrc) (% srcidx)) (% data0))
360    (movq (@ (+ 8 target::misc-data-offset) (% rsrc) (% srcidx)) (% data1))
361    (movq (% data0) (@ target::misc-data-offset (% dest) (% destidx)))
362    (movq (% data1) (@ (+ 8 target::misc-data-offset) (% dest) (% destidx)))
363    @test
364    (subq ($ '16) (% nbytes))
365    (jge @loop)
366    (movq (% dest) (% arg_z))
367    (single-value-return 4)))
368
369(defx86lapfunction %copy-ivector-to-ivector-postincrement-128bit ((src 16) (src-byte-offset 8) #||(ra 0)||# (dest arg_x) (dest-byte-offset arg_y) (nbytes arg_z))
370  (let ((rsrc temp0)
371        (srcidx imm0)
372        (destidx imm1))
373    (movq (@ src (% rsp)) (% rsrc))
374    (movq (@ src-byte-offset (% rsp)) (% srcidx))
375    (sarq ($ target::fixnumshift) (% srcidx))
376    (movq (% dest-byte-offset) (% destidx))
377    (sarq ($ target::fixnumshift) (% destidx))
378    (jmp @test)
379    @loop
380    (movdqa (@ target::misc-data-offset (% rsrc) (% srcidx)) (% xmm0))
381    (movdqa (@ (+ 16 target::misc-data-offset) (% rsrc) (% srcidx)) (% xmm1))
382    (movdqa (@ (+ 32 target::misc-data-offset) (% rsrc) (% srcidx)) (% xmm2))
383    (movdqa (@ (+ 48 target::misc-data-offset) (% rsrc) (% srcidx)) (% xmm3))
384    (movdqa (% xmm0) (@ target::misc-data-offset (% dest) (% destidx)))
385    (movdqa (% xmm1) (@ (+ 16 target::misc-data-offset) (% dest) (% destidx)))
386    (movdqa (% xmm2) (@ (+ 32 target::misc-data-offset) (% dest) (% destidx)))
387    (movdqa (% xmm3) (@ (+ 48 target::misc-data-offset) (% dest) (% destidx)))
388    (lea (@ 64 (% destidx)) (% destidx))
389    (lea (@ 64 (% srcidx)) (% srcidx))
390    (subq ($ '64) (% nbytes))
391    @test
392    (cmpq ($ '64) (% nbytes))
393    (jge @loop)
394    (testq (% nbytes) (% nbytes))
395    (je @done)
396    (cmpq ($ '32) (% nbytes))
397    (je @two)
398    (jl @one)
399    (movdqa (@ target::misc-data-offset (% rsrc) (% srcidx)) (% xmm0))
400    (movdqa (% xmm0) (@ target::misc-data-offset (% dest) (% destidx)))
401    (lea (@ 16 (% srcidx)) (% srcidx))
402    (lea (@ 16 (% destidx)) (% destidx))
403    @two
404    (movdqa (@ target::misc-data-offset (% rsrc) (% srcidx)) (% xmm0))
405    (movdqa (% xmm0) (@ target::misc-data-offset (% dest) (% destidx)))
406    (lea (@ 16 (% srcidx)) (% srcidx))
407    (lea (@ 16 (% destidx)) (% destidx))
408    @one
409    (movdqa (@ target::misc-data-offset (% rsrc) (% srcidx)) (% xmm0))
410    (movdqa (% xmm0) (@ target::misc-data-offset (% dest) (% destidx)))
411    @done
412    (movq (% dest) (% arg_z))
413    (single-value-return 4)))
414
415(defx86lapfunction %copy-ivector-to-ivector-predecrement-128bit ((src 16) (src-byte-offset 8) #||(ra 0)||# (dest arg_x) (dest-byte-offset arg_y) (nbytes arg_z))
416  (let ((rsrc temp0)
417        (srcidx imm0)
418        (destidx imm1))
419    (movq (@ src (% rsp)) (% rsrc))
420    (movq (@ src-byte-offset (% rsp)) (% srcidx))
421    (sarq ($ target::fixnumshift) (% srcidx))
422    (movq (% dest-byte-offset) (% destidx))
423    (sarq ($ target::fixnumshift) (% destidx))
424    (jmp @test)
425    @loop
426    (lea (@ -64 (% destidx)) (% destidx))
427    (lea (@ -64 (% srcidx)) (% srcidx))
428    (movdqa (@ target::misc-data-offset (% rsrc) (% srcidx)) (% xmm0))
429    (movdqa (@ (+ 16 target::misc-data-offset) (% rsrc) (% srcidx)) (% xmm1))
430    (movdqa (@ (+ 32 target::misc-data-offset) (% rsrc) (% srcidx)) (% xmm2))
431    (movdqa (@ (+ 48 target::misc-data-offset) (% rsrc) (% srcidx)) (% xmm3))
432    (movdqa (% xmm0) (@ target::misc-data-offset (% dest) (% destidx)))
433    (movdqa (% xmm1) (@ (+ 16 target::misc-data-offset) (% dest) (% destidx)))
434    (movdqa (% xmm2) (@ (+ 32 target::misc-data-offset) (% dest) (% destidx)))
435    (movdqa (% xmm3) (@ (+ 48 target::misc-data-offset) (% dest) (% destidx)))
436    (subq ($ '64) (% nbytes))
437    @test
438    (cmpq ($ '64) (% nbytes))
439    (jge @loop)
440    (testq (% nbytes) (% nbytes))
441    (je @done)
442    (cmpq ($ '32) (% nbytes))
443    (je @two)
444    (jl @one)
445    (lea (@ -16 (% srcidx)) (% srcidx))
446    (lea (@ -16 (% destidx)) (% destidx))
447    (movdqa (@ target::misc-data-offset (% rsrc) (% srcidx)) (% xmm0))
448    (movdqa (% xmm0) (@ target::misc-data-offset (% dest) (% destidx)))
449    @two
450    (lea (@ -16 (% srcidx)) (% srcidx))
451    (lea (@ -16 (% destidx)) (% destidx))
452    (movdqa (@ target::misc-data-offset (% rsrc) (% srcidx)) (% xmm0))
453    (movdqa (% xmm0) (@ target::misc-data-offset (% dest) (% destidx)))
454    @one
455    (lea (@ -16 (% srcidx)) (% srcidx))
456    (lea (@ -16 (% destidx)) (% destidx))
457    (movdqa (@ target::misc-data-offset (% rsrc) (% srcidx)) (% xmm0))
458    (movdqa (% xmm0) (@ target::misc-data-offset (% dest) (% destidx)))
459    @done
460    (movq (% dest) (% arg_z))
461    (single-value-return 4)))
462
463
464(defx86lapfunction %copy-gvector-to-gvector ((src (* 2 x8664::node-size))
465                                             (src-element (* 1 x8664::node-size))
466                                             #|(ra 0)|#
467                                             (dest arg_x)
468                                             (dest-element arg_y)
469                                             (nelements arg_z))
470  (let ((rsrc temp0)
471        (rsrc-element imm1)
472        (val temp1))
473    (movq (@ src-element (% rsp)) (% rsrc-element))
474    (movq (@ src (% rsp)) (% rsrc))
475    (cmpq (% rsrc) (% dest))
476    (jne @front)
477    (rcmp (% rsrc-element) (% dest-element))
478    (jl @back)
479    @front
480    (testq (% nelements) (% nelements))
481    (jmp @front-test)
482    @front-loop
483    (movq (@ x8664::misc-data-offset (% rsrc) (% rsrc-element)) (% val))
484    (addq ($ '1) (% rsrc-element))
485    (movq (% val) (@ x8664::misc-data-offset (% dest) (% dest-element)))
486    (addq ($ '1) (% dest-element))
487    (subq ($ '1) (% nelements))
488    @front-test
489    (jne @front-loop)
490    (movq (% dest) (% arg_z))
491    (single-value-return 4)
492    @back
493    (addq (% nelements) (% rsrc-element))
494    (addq (% nelements) (% dest-element))
495    (testq (% nelements) (% nelements))
496    (jmp @back-test)
497    @back-loop
498    (subq ($ '1) (% rsrc-element))
499    (movq (@ x8664::misc-data-offset (% rsrc) (% rsrc-element)) (% val))
500    (subq ($ '1) (% dest-element))
501    (movq (% val) (@ x8664::misc-data-offset (% dest) (% dest-element)))
502    (subq ($ '1) (% nelements))
503    @back-test
504    (jne @back-loop)
505    (movq (% dest) (% arg_z))
506    (single-value-return 4)))
507
508(defx86lapfunction %heap-bytes-allocated ()
509  (movq (:rcontext x8664::tcr.save-allocptr) (% temp1))
510  (movq (:rcontext x8664::tcr.last-allocptr) (% temp0))
511  (cmpq ($ -16) (% temp1))
512  (movq (:rcontext x8664::tcr.total-bytes-allocated) (% imm0))
513  (jz @go)
514  (movq (% temp0) (% temp2))
515  (subq (% temp1) (% temp0))
516  (testq (% temp2) (% temp2))
517  (jz @go)
518  (add (% temp0) (% imm0))
519  @go
520  (jmp-subprim .SPmakeu64))
521
522
523(defx86lapfunction values ()
524  (:arglist (&rest values))
525  (save-frame-variable-arg-count)
526  (push-argregs)
527  (jmp-subprim .SPnvalret))
528
529(defx86lapfunction rdtsc ()
530  (:byte #x0f)                          ;two-byte rdtsc opcode
531  (:byte #x31)                          ;is #x0f #x31
532  (shlq ($ 32) (% rdx))
533  (orq (% rdx) (% rax))
534  (imul ($ (* 2 target::node-size)) (% rax) (% arg_z))
535  (shrq ($ 1) (% arg_z))
536  (single-value-return))
537
538;;; Return all 64 bits of the time-stamp counter as an unsigned integer.
539(defx86lapfunction rdtsc64 ()
540  (:byte #x0f)                          ;two-byte rdtsc opcode
541  (:byte #x31)                          ;is #x0f #x31
542  (shlq ($ 32) (% rdx))
543  (orq (% rdx) (% rax))
544  (jmp-subprim .SPmakeu64))
545
546;;; It would be nice if (%setf-macptr macptr (ash (the fixnum value)
547;;; ash::fixnumshift)) would do this inline.
548
549(defx86lapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z))
550  (check-nargs 2)
551  (trap-unless-typecode= macptr x8664::subtag-macptr)
552  (movq (% object) (@ x8664::macptr.address (% macptr)))
553  (single-value-return))
554
555(defx86lapfunction %fixnum-from-macptr ((macptr arg_z))
556  (check-nargs 1)
557  (trap-unless-typecode= arg_z x8664::subtag-macptr)
558  (movq (@ x8664::macptr.address (% arg_z)) (% imm0))
559  (trap-unless-lisptag= imm0 x8664::tag-fixnum imm1)
560  (movq (% imm0) (% arg_z))
561  (single-value-return))
562
563
564(defx86lapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z))
565  (trap-unless-typecode= ptr x8664::subtag-macptr)
566  (macptr-ptr ptr imm1)
567  (unbox-fixnum offset imm0)
568  (movq (@ (% imm1) (% imm0)) (% imm0))
569  (jmp-subprim .SPmakeu64))
570
571
572(defx86lapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z))
573  (trap-unless-typecode= ptr x8664::subtag-macptr)
574  (macptr-ptr ptr imm1)
575  (unbox-fixnum offset imm0)
576  (movq (@ (% imm1) (% imm0)) (% imm0))
577  (jmp-subprim .SPmakes64))
578
579
580
581
582(defx86lapfunction %%set-unsigned-longlong ((ptr arg_x)
583                                            (offset arg_y)
584                                            (val arg_z))
585  (save-simple-frame)
586  (trap-unless-typecode= ptr x8664::subtag-macptr)
587  (call-subprim .SPgetu64)
588  (macptr-ptr ptr imm2)
589  (unbox-fixnum offset imm1)
590  (movq (% imm0) (@ (% imm2) (% imm1)))
591  (restore-simple-frame)
592  (single-value-return))
593
594
595(defx86lapfunction %%set-signed-longlong ((ptr arg_x)
596                                          (offset arg_y)
597                                          (val arg_z))
598  (save-simple-frame)
599  (trap-unless-typecode= ptr x8664::subtag-macptr)
600  (call-subprim .SPgets64)
601  (macptr-ptr ptr imm2)
602  (unbox-fixnum offset imm1)
603  (movq (% imm0) (@ (% imm2) (% imm1)))
604  (restore-simple-frame)
605  (single-value-return))
606
607(defx86lapfunction interrupt-level ()
608  (movq (:rcontext x8664::tcr.tlb-pointer) (% imm1))
609  (movq (@ x8664::interrupt-level-binding-index (% imm1)) (% arg_z))
610  (single-value-return))
611
612(defx86lapfunction set-interrupt-level ((new arg_z))
613  (movq (:rcontext x8664::tcr.tlb-pointer) (% imm1))
614  (trap-unless-fixnum new)
615  (movq (% new) (@ x8664::interrupt-level-binding-index (% imm1)))
616  (single-value-return))
617
618(defx86lapfunction %current-tcr ()
619  (movq (:rcontext x8664::tcr.linear) (% arg_z))
620  (single-value-return))
621
622(defx86lapfunction %tcr-toplevel-function ((tcr arg_z))
623  (check-nargs 1)
624  (cmpq (% tcr) (:rcontext x8664::tcr.linear))
625  (movq (% rsp) (% imm0))
626  (movq (@ x8664::tcr.vs-area (% tcr)) (% temp0))
627  (movq (@ x8664::area.high (% temp0)) (% imm1))
628  (jz @room)
629  (movq (@ x8664::area.active (% temp0)) (% imm0))
630  @room
631  (cmpq (% imm1) (% imm0))
632  (movl ($ (target-nil-value)) (%l arg_z))
633  (cmovneq (@ (- x8664::node-size) (% imm1)) (% arg_z))
634  (single-value-return))
635
636(defx86lapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z))
637  (check-nargs 2)
638  (cmpq (% tcr) (:rcontext x8664::tcr.linear))
639  (movq (% rsp) (% imm0))
640  (movq (@ x8664::tcr.vs-area (% tcr)) (% temp0))
641  (movq (@ x8664::area.high (% temp0)) (% imm1))
642  (jz @room)
643  (movq (@ x8664::area.active (% temp0)) (% imm0))
644  @room
645  (cmpq (% imm1) (% imm0))
646  (leaq (@ (- x8664::node-size) (% imm1)) (% imm1))
647  (movq ($ 0) (@ (% imm1)))
648  (jne @have-room)
649  (movq (% imm1) (@ x8664::area.active (% temp0)))
650  (movq (% imm1) (@ x8664::tcr.save-vsp (% tcr)))
651  @have-room
652  (movq (% fun) (@ (% imm1)))
653  (single-value-return))
654
655;;; This needs to be done out-of-line, to handle EGC memoization.
656(defx86lapfunction %store-node-conditional ((offset 8) #|(ra 0)|# (object arg_x) (old arg_y) (new arg_z))
657  (movq (@ offset (% rsp)) (% temp0))
658  (save-simple-frame)
659  (call-subprim .SPstore-node-conditional)
660  (restore-simple-frame)
661  (single-value-return 3))
662
663(defx86lapfunction %store-immediate-conditional ((offset 8) #|(ra 0)|# (object arg_x) (old arg_y) (new arg_z))
664  (movq (@ offset (% rsp)) (% temp0))
665  (unbox-fixnum temp0 imm1)
666  (movq (% old) (% rax))
667  (lock)
668  (cmpxchgq (% new) (@ (% object) (% imm1)))
669  (jne @lose)
670  (movl ($ (target-t-value)) (%l arg_z))
671  (single-value-return 3)
672  @lose
673  (movl ($ (target-nil-value)) (%l arg_z))
674  (single-value-return 3))
675
676;;; AFAICT, this is GC-safe
677(defx86lapfunction set-%gcable-macptrs% ((ptr x8664::arg_z))
678  @again
679  (movq (@ (+ (target-nil-value) (x8664::kernel-global gcable-pointers)))
680        (% rax))
681  (movq (% rax) (@ x8664::xmacptr.link (% ptr)))
682  (lock)
683  (cmpxchgq (% ptr) (@ (+ (target-nil-value) (x8664::kernel-global gcable-pointers))))
684  (jne @again)
685  (single-value-return))
686
687#||
688(defun set-%gcable-macptrs% (ptr)
689  (with-exception-lock
690      (%set-%gcable-macptrs% ptr)))
691
692(defx86lapfunction %set-%gcable-macptrs% ((ptr x8664::arg_z))
693  ;; We must own the exception lock here.
694  (movq (@ (+ (target-nil-value) (x8664::kernel-global gcable-pointers)))
695        (% temp0))
696  (movq (% temp0) (@ x8664::xmacptr.link (% ptr)))
697  (movq (% ptr) (@ (+ (target-nil-value) (x8664::kernel-global gcable-pointers))))
698  (single-value-return))
699
700||#
701
702;;; Atomically increment or decrement the gc-inhibit-count kernel-global
703;;; (It's decremented if it's currently negative, incremented otherwise.)
704(defx86lapfunction %lock-gc-lock ()
705  @again
706  (movq (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count))) (% rax))
707  (lea (@ '-1 (% rax)) (% temp0))
708  (lea (@ '1 (% rax)) (% arg_z))
709  (testq (% rax) (% rax))
710  (cmovsq (% temp0) (% arg_z))
711  (lock)
712  (cmpxchgq (% arg_z) (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count))))
713  (jz @win)
714  (pause)
715  (jmp @again)
716  @win
717  (single-value-return))
718
719;;; Atomically decrement or increment the gc-inhibit-count kernel-global
720;;; (It's incremented if it's currently negative, decremented otherwise.)
721;;; If it's incremented from -1 to 0, try to GC (maybe just a little.)
722(defx86lapfunction %unlock-gc-lock ()
723  @again
724  (movq (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count)))
725        (% rax))
726  (lea (@ '1 (% rax)) (% arg_x))
727  (cmpq ($ -1) (% rax))
728  (lea (@ '-1 (% rax)) (% arg_z))
729  (cmovleq (% arg_x) (% arg_z))
730  (lock)
731  (cmpxchgq (% arg_z) (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count))))
732  (je @win)
733  (pause)
734  (jmp @again)
735  @win
736  (cmpq ($ '-1) (% rax))
737  (jne @done)
738  ;; The GC tried to run while it was inhibited.  Unless something else
739  ;; has just inhibited it, it should be possible to GC now.
740  (mov ($ arch::gc-trap-function-immediate-gc) (% imm0))
741  (uuo-gc-trap)
742  @done
743  (single-value-return))
744
745;;; Return true iff we were able to increment a non-negative
746;;; lock._value
747
748(defx86lapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
749  (check-nargs 3)
750  (unbox-fixnum disp imm1)
751  @again
752  (movq (@ (% node) (% imm1)) (% rax))
753  (lea (@ (% rax) (% by)) (% arg_z))
754  (lock)
755  (cmpxchgq (% arg_z) (@ (% node) (% imm1)))
756  (je @win)
757  (pause)
758  (jmp @again)
759  @win
760  (single-value-return))
761
762(defx86lapfunction %atomic-incf-ptr ((ptr arg_z))
763  (macptr-ptr ptr imm2)
764  @again
765  (movq (@ (% imm2)) (% rax))
766  (lea (@ 1 (% rax)) (% imm1))
767  (lock)
768  (cmpxchgq (% imm1) (@ (% imm2)))
769  (je @win)
770  (pause)
771  (jmp @again)
772  @win
773  (box-fixnum imm1 arg_z)
774  (single-value-return))
775
776(defx86lapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z))
777  (macptr-ptr ptr imm2)
778  @again
779  (movq (@ (% imm2)) (% rax))
780  (unbox-fixnum by imm1)
781  (add (% rax) (% imm1))
782  (lock)
783  (cmpxchgq (% imm1) (@ (% imm2)))
784  (jz @win)
785  (pause)
786  (jmp @again)
787  @win
788  (box-fixnum imm1 arg_z)
789  (single-value-return))
790
791
792(defx86lapfunction %atomic-decf-ptr ((ptr arg_z))
793  (macptr-ptr ptr imm2)
794  @again
795  (movq (@ (% imm2)) (% rax))
796  (lea (@ -1 (% rax)) (% imm1))
797  (lock)
798  (cmpxchgq (% imm1) (@ (% imm2)))
799  (jz @win)
800  (pause)
801  (jmp @again)
802  @win
803  (box-fixnum imm1 arg_z)
804  (single-value-return))
805
806(defx86lapfunction %atomic-decf-ptr-if-positive ((ptr arg_z))
807  (macptr-ptr ptr imm2)
808  @again
809  (movq (@ (% imm2)) (% rax))
810  (testq (% rax) (% rax))
811  (lea (@ -1 (% rax)) (% imm1))
812  (jz @done)
813  (lock)
814  (cmpxchgq (% imm1) (@ (% imm2)))
815  (jz @done)
816  (pause)
817  (jmp @again)
818  @done
819  (box-fixnum imm1 arg_z)
820  (single-value-return))
821
822
823(defx86lapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z))
824  (macptr-ptr arg_y imm1)
825  (unbox-fixnum newval imm0)
826  (lock)
827  (xchgq (% imm0) (@ (% imm1)))
828  (box-fixnum imm0 arg_z)
829  (single-value-return))
830
831;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value
832;;; was equal to OLDVAL.  Return the old value
833(defx86lapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
834  (macptr-ptr ptr imm2)
835  (unbox-fixnum expected-oldval imm0)
836  (lock)
837  (cmpxchgq (% imm1) (@ (% imm2)))
838  (box-fixnum imm0 arg_z)
839  (single-value-return))
840
841(defx86lapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
842  (let ((address imm1))
843    (macptr-ptr ptr address)
844    (movq (% expected-oldval) (% imm0))
845    (lock)
846    (cmpxchgq (% newval) (@ (% address)))
847    (movq (% imm0) (% arg_z))
848    (single-value-return)))
849
850(defx86lapfunction xchgl ((newval arg_y) (ptr arg_z))
851  (unbox-fixnum newval imm0)
852  (macptr-ptr ptr imm1)
853  (lock)                                ; implicit ?
854  (xchgl (% imm0.l) (@ (% imm1)))
855  (box-fixnum imm0 arg_z)
856  (single-value-return))
857 
858                         
859
860
861(defx86lapfunction %macptr->dead-macptr ((macptr arg_z))
862  (check-nargs 1)
863  (movb ($ x8664::subtag-dead-macptr) (@ x8664::misc-subtag-offset (% macptr)))
864  (single-value-return))
865
866
867
868
869 
870(defx86lapfunction %%save-application ((flags arg_y) (fd arg_z))
871  (unbox-fixnum flags imm0)
872  (orq ($ arch::gc-trap-function-save-application) (% imm0))
873  (unbox-fixnum fd imm1)
874  (uuo-gc-trap)
875  (single-value-return))
876
877
878
879(defx86lapfunction %misc-address-fixnum ((misc-object arg_z))
880  (check-nargs 1)
881  (lea (@ x8664::misc-data-offset (% misc-object)) (% arg_z))
882  (single-value-return))
883
884
885(defx86lapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z))
886  (check-nargs 3)
887  (macptr-ptr ptr imm1) ; address in macptr
888  (lea (@ 17 (% imm1)) (% imm0))     ; 2 for delta + 15 for alignment
889  (andb ($ -16) (%b  imm0))   ; Clear low four bits to align
890  (subq (% imm0) (% imm1))  ; imm1 = -delta
891  (negw (%w imm1))
892  (movw (%w imm1) (@  -2 (% imm0)))     ; save delta halfword
893  (unbox-fixnum subtype imm1)  ; subtype at low end of imm1
894  (shlq ($ (- x8664::num-subtag-bits x8664::fixnum-shift)) (% len ))
895  (orq (% len) (% imm1))
896  (movq (% imm1) (@ (% imm0)))       ; store subtype & length
897  (lea (@ x8664::fulltag-misc (% imm0)) (% arg_z)) ; tag it, return it
898  (single-value-return))
899
900(defx86lapfunction %%make-disposable ((ptr arg_y) (vector arg_z))
901  (check-nargs 2)
902  (lea (@ (- x8664::fulltag-misc) (% vector)) (% imm0)) ; imm0 is addr = vect less tag
903  (movzwq (@ -2 (% imm0)) (% imm1))     ; get delta
904  (subq (% imm1) (% imm0))              ; vector addr (less tag)  - delta is orig addr
905  (movq (% imm0) (@ x8664::macptr.address (% ptr)))
906  (single-value-return))
907
908
909(defx86lapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z))
910  (lea (@ x8664::misc-data-offset (% vect)) (% imm0))
911  (movq (% imm0) (@ x8664::macptr.address (% ptr)))
912  (single-value-return))
913
914(defx86lapfunction %ivector-from-macptr ((ptr arg_z))
915  (macptr-ptr ptr imm0)
916  (lea (@ (- target::fulltag-misc target::node-size) (% imm0)) (% arg_z))
917  (single-value-return))
918
919(defx86lapfunction get-saved-register-values ()
920  (movq (% rsp) (% temp0))
921  (push (% save0))
922  (push (% save1))
923  (push (% save2))
924  (push (% save3))                      ; this'd be the TCR on Win64.
925  (set-nargs 4)
926  (jmp-subprim .SPvalues))
927
928
929(defx86lapfunction %current-db-link ()
930  (movq (:rcontext x8664::tcr.db-link) (% arg_z))
931  (single-value-return))
932
933(defx86lapfunction %no-thread-local-binding-marker ()
934  (movq ($ x8664::subtag-no-thread-local-binding) (% arg_z))
935  (single-value-return))
936
937
938(defx86lapfunction pending-user-interrupt ()
939  (xorq (% imm0) (% imm0))
940  (ref-global x8664::intflag arg_z)
941  ;; If another signal happens now, it will get ignored, same as if it happened
942  ;; before whatever signal is in arg_z.  But then these are async signals, so
943  ;; who can be sure it didn't actually happen just before...
944  (set-global imm0 x8664::intflag)
945  (single-value-return))
946
947
948(defx86lapfunction debug-trap-with-string ((arg arg_z))
949  (check-nargs 1)
950  (uuo-error-debug-trap-with-string)
951  (single-value-return))
952
953(defx86lapfunction %safe-get-ptr ((src arg_y) (dest arg_z))
954  (check-nargs 2)
955  (save-simple-frame)
956  (macptr-ptr src imm0)
957  (leaq (@ (:^ done) (% fn)) (% ra0))
958  (movq (% imm0) (:rcontext x8664::tcr.safe-ref-address))
959  (movq (@ (% imm0)) (% imm0))
960  (jmp done)
961  (:tra done)
962  (recover-fn-from-rip)
963  (movq ($ 0) (:rcontext x8664::tcr.safe-ref-address))
964  (movq (% imm0) (@ x8664::macptr.address (% dest)))
965  (restore-simple-frame)
966  (single-value-return))
967
968;;; This was intentded to work around a bug in #_nanosleep in early
969;;; Leopard test releases.  It's probably not necessary any more; is
970;;; it still called ?
971
972(defx86lapfunction %check-deferred-gc ()
973  (btq ($ (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)) (:rcontext x8664::tcr.flags))
974  (movl ($ (target-nil-value)) (% arg_z.l))
975  (jae @done)
976  (ud2a)
977  (:byte 3)
978  (movl ($ (target-t-value)) (% arg_z.l))
979  @done
980  (single-value-return))
981
982(defx86lapfunction %%tcr-interrupt ((target arg_z))
983  (check-nargs 1)
984  (ud2a)
985  (:byte 4)
986  (box-fixnum imm0 arg_z)
987  (single-value-return))
988
989(defx86lapfunction %suspend-tcr ((target arg_z))
990  (check-nargs 1)
991  (ud2a)
992  (:byte 5)
993  (movzbl (%b imm0) (%l imm0))
994  (testl (%l imm0) (%l imm0))
995  (movl ($ (target-nil-value)) (%l arg_z))
996  (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z))
997  (single-value-return))
998
999(defx86lapfunction %suspend-other-threads ()
1000  (check-nargs 0)
1001  (ud2a)
1002  (:byte 6)
1003  (movl ($ (target-nil-value)) (%l arg_z))
1004  (single-value-return))
1005
1006(defx86lapfunction %resume-tcr ((target arg_z))
1007  (check-nargs 1)
1008  (ud2a)
1009  (:byte 7)
1010  (movzbl (%b imm0) (%l imm0))
1011  (testl (%l imm0) (%l imm0))
1012  (movl ($ (target-nil-value)) (%l arg_z))
1013  (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z))
1014  (single-value-return))
1015
1016(defx86lapfunction %resume-other-threads ()
1017  (check-nargs 0)
1018  (ud2a)
1019  (:byte 8)
1020  (movl ($ (target-nil-value)) (%l arg_z))
1021  (single-value-return))
1022
1023(defx86lapfunction %kill-tcr ((target arg_z))
1024  (check-nargs 1)
1025  (ud2a)
1026  (:byte 9)
1027  (testb (%b imm0) (%b imm0))
1028  (movl ($ (target-nil-value)) (%l arg_z))
1029  (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z))
1030  (single-value-return))
1031 
1032
1033(defx86lapfunction %get-spin-lock ((p arg_z))
1034  (check-nargs 1)
1035  (save-simple-frame)
1036  @again
1037  (macptr-ptr arg_z imm1)
1038  (movq (@ '*spin-lock-tries* (% fn)) (% temp0))
1039  (movq (@ '*spin-lock-timeouts* (% fn)) (% temp1))
1040  (movq (@ target::symbol.vcell (% temp0)) (% temp0))
1041  (movq (:rcontext x8664::tcr.linear) (% arg_y))
1042  @try-swap
1043  (xorq (% rax) (% rax))
1044  (lock)
1045  (cmpxchgq (% arg_y) (@ (% imm1)))
1046  (je @done)
1047  @spin
1048  (pause)
1049  (cmpq ($ 0) (@ (% imm1)))
1050  (je @try-swap)
1051  (subq ($ '1) (% temp0))
1052  (jne @spin)
1053  @wait
1054  (addq ($ x8664::fixnumone) (@ x8664::symbol.vcell (% temp1)))
1055  (pushq (% arg_z))
1056  (call-symbol yield 0)
1057  (popq (% arg_z))
1058  (jmp @again)
1059  @done
1060  (restore-simple-frame)
1061  (single-value-return))
1062
1063;;; This is a prototype; it can't easily keep its arguments on the stack,
1064;;; or in registers, because its job involves unwinding the stack and
1065;;; restoring registers.  Its parameters are thus kept in constants,
1066;;; and this protoype is cloned (with the right parameters).
1067
1068;;; For win64 (which doesn't really have a "save3" register), the code
1069;;; which instantiates this should always set save3-offset to 0.
1070(defx86lapfunction %%apply-in-frame-proto ()
1071  (:fixed-constants (target-frame target-catch target-db-link target-xcf target-tsp target-foreign-sp save0-offset save1-offset save2-offset save3-offset function args))
1072  (check-nargs 0)
1073  ;;(uuo-error-debug-trap)
1074  (movq (@ 'target-catch (% fn)) (% temp0))
1075  (xorl (%l imm0) (%l imm0))
1076  (cmpb ($ x8664::fulltag-nil) (%b temp0))
1077  (movq (:rcontext target::tcr.catch-top) (% arg_z))
1078  (jz @did-catch)
1079  @find-catch
1080  (testq (% arg_z) (% arg_z))
1081  (jz @did-catch)                       ; never found target catch
1082  (addq ($ '1)  (% imm0))
1083  (cmpq (% temp0) (% arg_z))
1084  (je @found-catch)
1085  (movq (@ target::catch-frame.link (% arg_z)) (% arg_z))
1086  (jmp @find-catch)
1087  @found-catch
1088  (set-nargs 0)                         ; redundant, but ...
1089  (lea (@ (:^ @back-from-nthrow) (% fn)) (% ra0))
1090  (:talign 4)
1091  (jmp-subprim .SPnthrowvalues)
1092  @back-from-nthrow
1093  (recover-fn-from-rip)
1094  @did-catch
1095  ;; Restore special bindings
1096  (movq (@ 'target-db-link (% fn)) (% imm0))
1097  (cmpb ($ x8664::fulltag-nil) (%b imm0))
1098  (jz @no-unbind)
1099  (call-subprim .SPunbind-to)
1100  @no-unbind
1101  ;; If there's at least one exception frame between the target
1102  ;; frame and the last catch (or the point of departure), restore
1103  ;; the NVRs and foreign sp from the oldest such frame
1104  (movq (@ 'target-xcf (% fn)) (% arg_z))
1105  (cmpb ($ x8664::fulltag-nil) (%b arg_z))
1106  (jz @no-xcf)
1107  (movq (@ target::xcf.xp (% arg_z)) (% arg_y))
1108  ;; arg_y points to a "portable" ucontext.  Find the platform-specifc
1109  ;; "gpr vector" in the uc_mcontext, load the NVRs and stack/frame
1110  ;; pointer from there.
1111  #+linuxx8664-target
1112  (progn
1113    (addq ($ gp-regs-offset) (% arg_y))
1114    (movq (@ (* #$REG_R15 8) (% arg_y)) (% r15))
1115    (movq (@ (* #$REG_R14 8) (% arg_y)) (% r14))
1116    (movq (@ (* #$REG_R12 8) (% arg_y)) (% r12))
1117    (movq (@ (* #$REG_R11 8) (% arg_y)) (% r11))
1118    (movq (@ (* #$REG_RBP 8) (% arg_y)) (% rbp))
1119    (movq (@ (* #$REG_RSP 8) (% arg_y)) (% rsp)))
1120  #+freebsdx8664-target
1121  (progn
1122    ;; If you think that this is ugly, just wait until you see the Darwin
1123    ;; version.
1124    (addq ($ gp-regs-offset) (% arg_y))
1125    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r15)) -3) (% arg_y)) (% r15))
1126    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r14)) -3) (% arg_y)) (% r14))
1127    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r12)) -3) (% arg_y)) (% r12))
1128    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r11)) -3) (% arg_y)) (% r11))
1129    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rbp)) -3) (% arg_y)) (% rbp))
1130    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rsp)) -3) (% arg_y)) (% rsp)))
1131  #+darwinx8664-target
1132  (progn
1133    ;; Yes, this is ugly.
1134    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_ucontext)) :uc_mcontext)) -3) (% arg_y)) (% arg_y))
1135    (addq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_mcontext64)) :__ss)) -3)) (% arg_y))
1136    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r15)) -3) (% arg_y)) (% r15))
1137    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r14)) -3) (% arg_y)) (% r14))
1138    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r12)) -3) (% arg_y)) (% r12))
1139    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r11)) -3) (% arg_y)) (% r11))
1140    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__rbp)) -3) (% arg_y)) (% rbp))
1141    (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__rsp)) -3) (% arg_y)) (% rsp)))
1142  ;; This is our best (possibly only) chance to get
1143  ;; the foreign sp right.
1144  (movq (@ target::xcf.prev-xframe (% arg_z)) (% temp0))
1145  (movq (@ target::xcf.foreign-sp (% arg_z)) (% imm0))
1146  (movq (% temp0) (:rcontext target::tcr.xframe))
1147  (movq (% imm0) (:rcontext target::tcr.foreign-sp))
1148  ;; All done processing the xcf.  NVRs may have been
1149  ;; saved between the last catch/last xcf and the
1150  ;; target frame.  The save-n-offset parameter/constants
1151  ;; are either 0 or negative offsets from the target frame
1152  ;; of the stack location where the corresponding GPR
1153  ;; was saved.
1154  @no-xcf
1155  (movq (@ 'target-tsp (% fn)) (% imm0))
1156  (cmpb ($ x8664::fulltag-nil) (%b imm0))
1157  (movq (@ 'target-foreign-sp (% fn)) (% temp0))
1158  (je @no-tsp)
1159  (movq (% imm0) (:rcontext target::tcr.save-tsp))
1160  (movq (% imm0) (:rcontext target::tcr.next-tsp))
1161  @no-tsp
1162  (cmpb ($ x8664::fulltag-nil) (%b temp0))
1163  (je @no-sp)
1164  (movq (% temp0) (:rcontext target::tcr.foreign-sp))
1165  @no-sp
1166  (movq (@ 'target-frame (% fn)) (% rbp))
1167  (movq (@ 'save0-offset (% fn)) (% arg_x))
1168  (movq (@ 'save1-offset (% fn)) (% arg_y))
1169  (movq (@ 'save2-offset (% fn)) (% arg_z))
1170  (movq (@ 'save3-offset (% fn)) (% temp0))
1171  (testq (% arg_x) (% arg_x))
1172  (cmovneq (@ (% rbp) (% arg_x)) (% save0))
1173  (testq (% arg_y) (% arg_y))
1174  (cmovneq (@ (% rbp) (% arg_x)) (% save1))
1175  (testq (% arg_z) (% arg_z))
1176  (cmovneq (@ (% rbp) (% arg_x)) (% save2))
1177  (testq (% temp0) (% temp0))
1178  (cmovneq (@ (% rbp) (% arg_x)) (% save3))
1179  (leave)
1180  (pop (% temp0))                       ; return address, not used by subprim
1181  (set-nargs 0)
1182  (movq (@ 'args (% fn)) (% arg_z))
1183  (lea (@ (:^ @back-from-spread) (% fn)) (% ra0))
1184  (:talign 4)
1185  (jmp-subprim .SPspreadargz)
1186  @back-from-spread
1187  (recover-fn-from-rip)                 ; .SPspreadargz preserves %fn, but ...
1188  (push (% temp0))                      ; return address
1189  (jmp (@ 'function (% fn))))
1190 
1191
1192
1193
1194
1195 
1196(defx86lapfunction %staticp ((x arg_z))
1197  (check-nargs 1)
1198  (ref-global static-cons-area temp0)
1199  (movq (% x) (% imm0))
1200  (movl ($ (target-nil-value)) (% arg_z.l))
1201  (subq (@ target::area.low (% temp0)) (% imm0))
1202  (shrq ($ target::dnode-shift) (% imm0))
1203  (movq (@ target::area.ndnodes (% temp0)) (% imm1))
1204  (subq (% imm0) (% imm1))
1205  (lea (@ 128 (% imm1)) (% imm1))
1206  (leaq (@ (% imm1) target::fixnumone) (% imm1))
1207  (cmovaq (% imm1) (% arg_z))
1208  (single-value-return))
1209
1210(defx86lapfunction %static-inverse-cons ((n arg_z))
1211  (check-nargs 1)
1212  (testl ($ target::tagmask) (% arg_z.l))
1213  (jne @fail)
1214  (subq ($ '128) (% arg_z))
1215  (ref-global static-cons-area temp0)
1216  (movq (@ target::area.ndnodes (% temp0)) (% imm0))
1217  (box-fixnum imm0 arg_y)
1218  (rcmpq (% arg_z) (% arg_y))
1219  (ja @fail)
1220  (movq (@ target::area.high (% temp0)) (% imm0))
1221  (subq (% arg_z) (% imm0))
1222  (subq (% arg_z) (% imm0))
1223  (lea (@ x8664::fulltag-cons (% imm0)) (% arg_z))
1224  (cmpb ($ target::unbound-marker) (@ target::cons.car (% arg_z)))
1225  (je @fail)
1226  (single-value-return)
1227  @fail
1228  (movl ($ (target-nil-value)) (% arg_z.l))
1229  (single-value-return))
1230
1231
1232 
1233
1234;;; end of x86-misc.lisp
1235) ; #+x8664-target
Note: See TracBrowser for help on using the repository browser.