source: trunk/source/level-0/X86/X8632/x8632-utils.lisp @ 11523

Last change on this file since 11523 was 11523, checked in by gb, 11 years ago

x86 support for FLASH-FREEZE.
Use signed_natural in x86 gc-like functions.
RECURSIVE-LOCK-WHOSTATE and the RWLOCK-WHOSTATE functions: use
WITH-STANDARD-IO-SYNTAX when consing up the string. Do that in
higher-level code, to avoid early refs to CL-USER pacjage.
(In general, other things similar to RECURSIVE-LOCK-WHOSTATE are
suspect, in that they call (FORMAT NIL ...) in a random environment
where things like *PRINT-READABLY* may be in effect. There are
probably other cases of this.)

File size: 14.7 KB
RevLine 
[8077]1(in-package "CCL")
2
3(defx8632lapfunction %address-of ((arg arg_z))
4  ;; %address-of a fixnum is a fixnum, just for spite.
5  ;; %address-of anything else is the address of that thing as an integer.
6  (testb ($ x8632::fixnummask) (%b arg))
7  (je @done)
8  (movl (% arg) (% imm0))
9  (jmp-subprim .SPmakeu32)
10  @done
11  (single-value-return))
12
13;;; "areas" are fixnum-tagged and, for the most part, so are their
14;;; contents.
15
16;;; The nilreg-relative global all-areas is a doubly-linked-list header
17;;; that describes nothing.  Its successor describes the current/active
18;;; dynamic heap.  Return a fixnum which "points to" that area, after
19;;; ensuring that the "active" pointers associated with the current thread's
20;;; stacks are correct.
21
22(defx8632lapfunction %normalize-areas ()
23  (let ((address temp0)
24        (temp temp1))
25
26    ; update active pointer for tsp area.
[10575]27    (movl (:rcontext x8632::tcr.ts-area) (% address))
28    (movl (:rcontext x8632::tcr.save-tsp) (% temp))
[8077]29    (movl (% temp) (@ x8632::area.active (% address)))
30   
31    ;; Update active pointer for vsp area.
[10575]32    (movl (:rcontext x8632::tcr.vs-area) (% address))
[8077]33    (movl (% esp) (@ x8632::area.active (% address)))
34
35    (ref-global all-areas arg_z)
36    (movl (@ x8632::area.succ (% arg_z)) (% arg_z))
37
38    (single-value-return)))
39
40(defx8632lapfunction %active-dynamic-area ()
41  (ref-global all-areas arg_z)
42  (movl (@ x8632::area.succ (% arg_z)) (% arg_z))
43  (single-value-return))
44
45(defx8632lapfunction %object-in-stack-area-p ((object arg_y) (area arg_z))
46  (rcmp (% object) (@ x8632::area.active (% area)))
47  (movl ($ nil) (% temp0))
48  (movl ($ t) (% imm0))
49  (jb @done)
50  (rcmp (% object) (@ x8632::area.high (% area)))
51  (cmovbl (% imm0) (% temp0))
52  @done
53  (movl (% temp0) (% arg_z))
54  (single-value-return))
55
56(defx8632lapfunction %object-in-heap-area-p ((object arg_y) (area arg_z))
57  (rcmp (% object) (@ x8632::area.low (% area)))
58  (movl ($ nil) (% temp0))
59  (movl ($ t) (% imm0))
60  (jb @done)
61  (rcmp (% object) (@ x8632::area.active (% area)))
62  (cmovbl (% imm0) (% temp0))
63  @done
64  (movl (% temp0) (% arg_z))
65  (single-value-return))
66
[8746]67;;; In these heap-walking functions, all other threads should be
68;;; suspended; the only consing that should happen is any consing
69;;; that the function (the "f" argument) does when we call it.
70;;;
71;;; We can therefore basically walk dnode-aligned addresses (but we
72;;; have to be careful, especially in the %WALK-DYNAMIC-AREA case,
73;;; to hold onto only tagged pointers when we call the funtion, since
74;;; consing by the called function could cause a gc).
[8077]75
[8746]76(defx8632lapfunction walk-static-area ((a arg_y) (f arg_z))
77  (let ((obj temp0)
78        (fun -4)
79        (limit -8))
80    (save-simple-frame)
81    (push (% f))
82    (pushl (@ x8632::area.active (% a)))
83    (movl (@ x8632::area.low (% a)) (% obj))
84    (jmp @test)
85    @loop
86    (movb (@ (% obj)) (% imm0.b))
87    (andb ($ x8632::fulltagmask) (% imm0.b))
88    (cmpb ($ x8632::fulltag-immheader) (% imm0.b))
89    (je @misc)
90    (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b))
91    (je @misc)
92    ;; not a header, so must be a cons
93    (add ($ x8632::fulltag-cons) (% obj))
94    (mov (% obj) (% arg_z))
95    (set-nargs 1)
96    (push (% obj))
97    (:talign 5)
98    (call (@ fun (% ebp)))
99    (recover-fn)
100    (pop (% obj))
101    (add ($ (- x8632::cons.size x8632::fulltag-cons)) (% obj))
102    (jmp @test)
103    @misc
[11077]104    (lea (@ x8632::fulltag-misc (% obj)) (% arg_z))
[8746]105    (set-nargs 1)
106    (push (% obj))
107    (:talign 5)
108    (call (@ fun (% ebp)))
109    (recover-fn)
110    (pop (% obj))
[9271]111    (mov (@ (% obj)) (% imm0))
[8746]112    (andb ($ x8632::fulltagmask) (% imm0.b))
113    (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b))
[9271]114    (mov (@ (% obj)) (% imm0))
[8746]115    (je @32)
116    (cmpb ($ x8632::max-32-bit-ivector-subtag) (% imm0.b))
[11363]117    (jbe @32)
[8746]118    (cmpb ($ x8632::max-8-bit-ivector-subtag) (% imm0.b))
[11363]119    (jbe @8)
[8746]120    (cmpb ($ x8632::max-16-bit-ivector-subtag) (% imm0.b))
[11363]121    (jbe @16)
[8746]122    (cmpb ($ x8632::subtag-double-float-vector) (% imm0.b))
123    (je @double-float)
124    ;; if we get here, it's a bit vector
125    (shrl ($ x8632::num-subtag-bits) (% imm0))
126    (add ($ 7) (% imm0))
127    (shrl ($ 3) (% imm0))
128    (jmp @uvector-next)
129    @double-float
130    (shrl ($ x8632::num-subtag-bits) (% imm0))
131    (shll ($ 3) (% imm0))
132    (jmp @uvector-next)
133    @8
134    (shrl ($ x8632::num-subtag-bits) (% imm0))
135    (jmp @uvector-next)
136    @16
137    (shrl ($ x8632::num-subtag-bits) (% imm0))
138    (shll ($ 1) (% imm0))
139    (jmp @uvector-next)
140    @32
141    (shrl ($ x8632::num-subtag-bits) (% imm0))
142    (shll ($ 2) (% imm0))
143    ;; size of obj in bytes (without header or alignment padding)
144    ;; is in imm0
145    @uvector-next
146    (add ($ (+ x8632::node-size (1- x8632::dnode-size))) (% imm0))
147    (andb ($ (lognot (1- x8632::dnode-size))) (% imm0.b))
148    (add (% imm0) (% obj))
149    @test
150    (cmpl (@ limit (% ebp)) (% obj))
151    (jb @loop)
[10959]152    (movl ($ (target-nil-value)) (% arg_z))
[8746]153    (restore-simple-frame)
154    (single-value-return)))
[8077]155
[8746]156;;; This walks the active "dynamic" area.  Objects might be moving around
157;;; while we're doing this, so we have to be a lot more careful than we
158;;; are when walking a static area.
159;;; There are a couple of approaches to termination:
160;;;  a) Allocate a "sentinel" cons, and terminate when we run into it.
161;;;  b) Check the area limit (which is changing if we're consing) and
162;;;     terminate when we hit it.
163;;; (b) loses if the function conses.  (a) conses.  I can't think of anything
164;;; better than (a).
165;;; This, of course, assumes that any GC we're doing does in-place compaction
166;;; (or at least preserves the relative order of objects in the heap.)
[8077]167
[8746]168(defx8632lapfunction %walk-dynamic-area ((a arg_y) (f arg_z))
169  (let ((obj temp0)
170        (fun -4)
171        (sentinel -8))
172    (save-simple-frame)
173    (push (% f))
174    (subl ($ (- x8632::cons.size x8632::fulltag-cons))
[10575]175          (:rcontext x8632::tcr.save-allocptr))
176    (movl (:rcontext x8632::tcr.save-allocptr) (% allocptr)) ;aka temp0
177    (cmpl (:rcontext x8632::tcr.save-allocbase) (% allocptr))
[8746]178    (jg @ok)
179    (uuo-alloc)
180    @ok
181    (andb ($ (lognot x8632::fulltagmask))
[10575]182          (:rcontext x8632::tcr.save-allocptr))
[8746]183    (push (% allocptr))                 ;sentinel
184    (ref-global tenured-area a)
185    (movl (@ x8632::area.low (% a)) (% obj))
186    (jmp @test)
187    @loop
188    (movb (@ (% obj)) (% imm0.b))
189    (andb ($ x8632::fulltagmask) (% imm0.b))
190    (cmpb ($ x8632::fulltag-immheader) (% imm0.b))
191    (je @misc)
192    (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b))
193    (je @misc)
194    ;; not a header, so must be a cons
195    (add ($ x8632::fulltag-cons) (% obj))
196    (mov (% obj) (% arg_z))
197    (set-nargs 1)
198    (push (% obj))
199    (:talign 5)
200    (call (@ fun (% ebp)))
201    (recover-fn)
202    (pop (% obj))
203    (add ($ (- x8632::cons.size x8632::fulltag-cons)) (% obj))
204    (jmp @test)
205    @misc
206    (add ($ x8632::fulltag-misc) (% obj))
207    (mov (% obj) (% arg_z))
208    (set-nargs 1)
209    (push (% obj))
210    (:talign 5)
211    (call (@ fun (% ebp)))
212    (recover-fn)
213    (pop (% obj))
214    (sub ($ x8632::fulltag-misc) (% obj))
[9271]215    (mov (@ (% obj)) (% imm0))
[8746]216    (andb ($ x8632::fulltagmask) (% imm0.b))
[10741]217    (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b))
[9271]218    (mov (@ (% obj)) (% imm0))
[8746]219    (je @32)
220    (cmpb ($ x8632::max-32-bit-ivector-subtag) (% imm0.b))
[11363]221    (jbe @32)
[8746]222    (cmpb ($ x8632::max-8-bit-ivector-subtag) (% imm0.b))
[11363]223    (jbe @8)
[8746]224    (cmpb ($ x8632::max-16-bit-ivector-subtag) (% imm0.b))
[11363]225    (jbe @16)
[8746]226    (cmpb ($ x8632::subtag-double-float-vector) (% imm0.b))
227    (je @double-float)
228    ;; if we get here, it's a bit vector
229    (shrl ($ x8632::num-subtag-bits) (% imm0))
230    (add ($ 7) (% imm0))
231    (shrl ($ 3) (% imm0))
232    (jmp @uvector-next)
233    @double-float
234    (shrl ($ x8632::num-subtag-bits) (% imm0))
235    (shll ($ 3) (% imm0))
236    (jmp @uvector-next)
237    @8
238    (shrl ($ x8632::num-subtag-bits) (% imm0))
239    (jmp @uvector-next)
240    @16
241    (shrl ($ x8632::num-subtag-bits) (% imm0))
242    (shll ($ 1) (% imm0))
243    (jmp @uvector-next)
244    @32
245    (shrl ($ x8632::num-subtag-bits) (% imm0))
246    (shll ($ 2) (% imm0))
247    ;; size of obj in bytes (without header or alignment padding)
248    ;; is in imm0
249    @uvector-next
250    (add ($ (+ x8632::node-size (1- x8632::dnode-size))) (% imm0))
251    (andb ($ (lognot (1- x8632::dnode-size))) (% imm0.b))
252    (add (% imm0) (% obj))
253    @test
254    (cmpl (@ sentinel (% ebp)) (% obj))
255    (jb @loop)
256    @done
[10959]257    (movl ($ (target-nil-value)) (% arg_z))
[8746]258    (restore-simple-frame)
259    (single-value-return)))
260
261;;; xxx duplicated in level-0/x86-utils.lisp
262(defun walk-dynamic-area (area func)
263  (with-other-threads-suspended
264      (%walk-dynamic-area area func)))
265
[9126]266(defx8632lapfunction %class-of-instance ((i arg_z))
267  (svref i instance.class-wrapper arg_z)
268  (svref arg_z %wrapper-class arg_z)
269  (single-value-return))
270
271(defx8632lapfunction class-of ((x arg_z))
272  (check-nargs 1)
273  (extract-fulltag x imm0)
274  (cmpb ($ x8632::fulltag-misc) (% imm0.b))
[9312]275  (movl (% arg_z) (% imm0))
[9126]276  (jne @have-tag)
277  (extract-subtag x imm0)
278  @have-tag
279  (movl (@ '*class-table* (% fn)) (% temp1))
280  (movl (@ x8632::symbol.vcell (% temp1)) (% temp1))
281  (movzbl (% imm0.b) (% imm0))
282  (movl (@ x8632::misc-data-offset (% temp1) (% imm0) 4) (% temp0))
[10959]283  (cmpl ($ (target-nil-value)) (% temp0))
[9126]284  (je @bad)
285  ;; functionp?
286  (extract-typecode temp0 imm0)
287  (cmpb ($ x8632::subtag-function) (% imm0.b))
288  (jne @ret)
289  ;; jump to the function
290  (set-nargs 1)
291  (jmp (% temp0))
292  @bad
293  (load-constant no-class-error fname)
294  (set-nargs 1)
295  (jmp (@ x8632::symbol.fcell (% fname)))
296  @ret
297  (movl (% temp0) (% arg_z))            ;return frob from table
298  (single-value-return))
299
300(defx8632lapfunction gc ()
[9369]301  (check-nargs 0)
302  (movl ($ arch::gc-trap-function-gc) (% imm0))
303  (uuo-gc-trap)
304  (movl ($ nil) (% arg_z))
305  (single-value-return))
[9126]306
307(defx8632lapfunction full-gccount ()
[9369]308  (ref-global tenured-area arg_z)
309  (test (% arg_z) (% arg_z))
[10959]310  (cmovel (@ (+ (target-nil-value) (x8632::%kernel-global 'gc-count))) (% arg_z))
[9369]311  (cmovnel (@ x8632::area.gc-count (% arg_z)) (% arg_z))
312  (single-value-return))
[9126]313
314(defx8632lapfunction egc ((arg arg_z))
[9369]315  "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return
316the previous enabled status. Although this function is thread-safe (in
317the sense that calls to it are serialized), it doesn't make a whole lot
318of sense to be turning the EGC on and off from multiple threads ..."
[9474]319  (check-nargs 1)
320  (clrl imm0)
321  (cmp-reg-to-nil arg)
322  (setne (% imm0.b))
323  (movd (% imm0) (% mm0))
324  (movl ($ arch::gc-trap-function-egc-control) (% imm0))
325  (uuo-gc-trap)
[9369]326  (single-value-return))
[9126]327
328(defx8632lapfunction %configure-egc ((e0size 4)
329                                     #|(ra 0)|#
330                                     (e1size arg_y)
331                                     (e2size arg_z))
[9369]332  (check-nargs 3)
333  (movl (@ e0size (% esp)) (% temp0))
334  (movl ($ arch::gc-trap-function-configure-egc) (% imm0))
335  (uuo-gc-trap)
336  (single-value-return 3))
[9126]337
338(defx8632lapfunction purify ()
[9369]339  (check-nargs 0)
340  (movl ($ arch::gc-trap-function-purify) (% imm0))
341  (uuo-gc-trap)
342  (movl ($ nil) (% arg_z))
343  (single-value-return))
[9126]344
345(defx8632lapfunction impurify ()
[9369]346  (check-nargs 0)
347  (movl ($ arch::gc-trap-function-impurify) (% imm0))
348  (uuo-gc-trap)
349  (movl ($ nil) (% arg_z))
350  (single-value-return))
[9126]351
[9474]352(defx8632lapfunction lisp-heap-gc-threshold ()
353  "Return the value of the kernel variable that specifies the amount
354of free space to leave in the heap after full GC."
355  (check-nargs 0)
356  (movl ($ arch::gc-trap-function-get-lisp-heap-threshold) (% imm0))
357  (uuo-gc-trap)
358  (jmp-subprim .SPmakeu32))
359
360(defx8632lapfunction set-lisp-heap-gc-threshold ((new arg_z))
361  "Set the value of the kernel variable that specifies the amount of free
362space to leave in the heap after full GC to new-value, which should be a
363non-negative fixnum. Returns the value of that kernel variable (which may
364be somewhat larger than what was specified)."
365  (check-nargs 1)
366  (save-simple-frame)
367  (call-subprim .SPgetu32)
368  (movd (% imm0) (% mm0))
369  (movl ($ arch::gc-trap-function-set-lisp-heap-threshold) (% imm0))
370  (uuo-gc-trap)
371  (restore-simple-frame)
372  (jmp-subprim .SPmakeu32))
373
[8077]374(defx8632lapfunction use-lisp-heap-gc-threshold ()
375  "Try to grow or shrink lisp's heap space, so that the free space is (approximately) equal to the current heap threshold. Return NIL"
376  (check-nargs 0) 
377  (movl ($ arch::gc-trap-function-use-lisp-heap-threshold) (% imm0))
378  (uuo-gc-trap)
[10959]379  (movl ($ (target-nil-value)) (%l arg_z))
[8077]380  (single-value-return))
381
[10450]382(defx8632lapfunction freeze ()
383  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
384  (movl ($ arch::gc-trap-function-freeze) (% imm0))
385  (uuo-gc-trap)
386  (jmp-subprim .SPmakeu32))
387
[11523]388(defx8632lapfunction flash-freeze ()
389  "Like FREEZE, without the GC."
390  (movl ($ arch::gc-trap-function-flash-freeze) (% imm0))
391  (uuo-gc-trap)
392  (jmp-subprim .SPmakeu32))
393
[11521]394(defx8632lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
395  (check-nargs 2)
396  (save-simple-frame)
397  (ud2a)
398  (:byte 10)
399  (push (% arg_z))
400  (push (% allocptr))
401  (set-nargs 2)
402  (jmp-subprim .SPnvalret))
403
[8077]404;;; offset is a fixnum, one of the x8632::kernel-import-xxx constants.
405;;; Returns that kernel import, a fixnum.
406(defx8632lapfunction %kernel-import ((offset arg_z))
[8633]407  (unbox-fixnum arg_z imm0)
[10959]408  (addl (@ (+ (target-nil-value) (x8632::%kernel-global 'kernel-imports))) (% imm0))
[8633]409  (movl (@ (% imm0)) (% imm0))
410  (box-fixnum imm0 arg_z)
[8077]411  (single-value-return))
412
413(defx8632lapfunction %get-unboxed-ptr ((macptr arg_z))
414  (macptr-ptr arg_z imm0)
415  (movl (@ (% imm0)) (% arg_z))
416  (single-value-return))
417
418(defx8632lapfunction %revive-macptr ((p arg_z))
419  (movb ($ x8632::subtag-macptr) (@ x8632::misc-subtag-offset (% p)))
420  (single-value-return))
421
422(defx86lapfunction %macptr-type ((p arg_z))
423  (check-nargs 1)
424  (trap-unless-typecode= p x8632::subtag-macptr)
425  (svref p x8632::macptr.type-cell imm0)
426  (box-fixnum imm0 arg_z)
427  (single-value-return))
428 
429(defx86lapfunction %macptr-domain ((p arg_z))
430  (check-nargs 1)
431  (trap-unless-typecode= p x8632::subtag-macptr)
432  (svref p x8632::macptr.domain-cell imm0)
433  (box-fixnum imm0 arg_z)
434  (single-value-return))
435
436(defx8632lapfunction %set-macptr-type ((p arg_y) (new arg_z))
437  (check-nargs 2)
438  (trap-unless-typecode= p x8632::subtag-macptr)
439  (unbox-fixnum new imm0)
440  (svset p x8632::macptr.type-cell imm0)
441  (single-value-return))
442
443(defx8632lapfunction %set-macptr-domain ((p arg_y) (new arg_z))
444  (check-nargs 2)
445  (trap-unless-typecode= p x8632::subtag-macptr)
446  (unbox-fixnum new imm0)
447  (svset p x8632::macptr.domain-cell imm0)
448  (single-value-return))
449
450(defx8632lapfunction true ()
[9821]451  (pop (% temp0))
[8998]452  (subl ($ '2) (% nargs))
453  (leal (@ '2 (% esp) (% nargs)) (% imm0))
[8077]454  (cmoval (% imm0) (% esp))
[10959]455  (movl ($ (target-t-value)) (% arg_z))
[9821]456  (push (% temp0))
[8077]457  (single-value-return))
458
459(defx8632lapfunction false ()
[9821]460  (pop (% temp0))
[8998]461  (subl ($ '2) (% nargs))
462  (leal (@ '2 (% esp) (% nargs)) (% imm0))
[8077]463  (cmoval (% imm0) (% esp))
[10959]464  (movl ($ (target-nil-value)) (% arg_z))
[9821]465  (push (% temp0))
[8077]466  (single-value-return))
[9126]467
468(defx8632lapfunction int3 ()
469  (int ($ 3))
[10959]470  (single-value-return))
Note: See TracBrowser for help on using the repository browser.