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

Last change on this file since 11556 was 11556, checked in by rme, 11 years ago

Change the x86 consing sequence to use ja (instead of jg) after comparing
tcr.save_allocptr and tcr.save_allocbase. (If we can manage to reserve
a bigger chunk of heap space, it might happen that these two values differ
in sign, i.e., tcr.save_allocptr might be above #x80000000 and
tcr.save_allocbase below. Of course, it may be a few years yet
before we have to start worrying about crossing #x8000000000000000 on
the x86-64 port...)

Update %ALLOCATE-UVECTOR and CONS vinsns, the Cons and Misc_Alloc_Internal
macros used in subprims, and the %WALK-DYNAMIC-AREA LAP function.

Also change pc_luser_xp() to recognize the ja instruction. (It still
recognizes the jg too, but treats it as ja when emulating it.)

File size: 14.7 KB
Line 
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.
27    (movl (:rcontext x8632::tcr.ts-area) (% address))
28    (movl (:rcontext x8632::tcr.save-tsp) (% temp))
29    (movl (% temp) (@ x8632::area.active (% address)))
30   
31    ;; Update active pointer for vsp area.
32    (movl (:rcontext x8632::tcr.vs-area) (% address))
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
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).
75
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
104    (lea (@ x8632::fulltag-misc (% obj)) (% arg_z))
105    (set-nargs 1)
106    (push (% obj))
107    (:talign 5)
108    (call (@ fun (% ebp)))
109    (recover-fn)
110    (pop (% obj))
111    (mov (@ (% obj)) (% imm0))
112    (andb ($ x8632::fulltagmask) (% imm0.b))
113    (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b))
114    (mov (@ (% obj)) (% imm0))
115    (je @32)
116    (cmpb ($ x8632::max-32-bit-ivector-subtag) (% imm0.b))
117    (jbe @32)
118    (cmpb ($ x8632::max-8-bit-ivector-subtag) (% imm0.b))
119    (jbe @8)
120    (cmpb ($ x8632::max-16-bit-ivector-subtag) (% imm0.b))
121    (jbe @16)
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)
152    (movl ($ (target-nil-value)) (% arg_z))
153    (restore-simple-frame)
154    (single-value-return)))
155
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.)
167
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))
175          (:rcontext x8632::tcr.save-allocptr))
176    (movl (:rcontext x8632::tcr.save-allocptr) (% allocptr)) ;aka temp0
177    (cmpl (:rcontext x8632::tcr.save-allocbase) (% allocptr))
178    (ja @ok)
179    (uuo-alloc)
180    @ok
181    (andb ($ (lognot x8632::fulltagmask))
182          (:rcontext x8632::tcr.save-allocptr))
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))
215    (mov (@ (% obj)) (% imm0))
216    (andb ($ x8632::fulltagmask) (% imm0.b))
217    (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b))
218    (mov (@ (% obj)) (% imm0))
219    (je @32)
220    (cmpb ($ x8632::max-32-bit-ivector-subtag) (% imm0.b))
221    (jbe @32)
222    (cmpb ($ x8632::max-8-bit-ivector-subtag) (% imm0.b))
223    (jbe @8)
224    (cmpb ($ x8632::max-16-bit-ivector-subtag) (% imm0.b))
225    (jbe @16)
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
257    (movl ($ (target-nil-value)) (% arg_z))
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
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))
275  (movl (% arg_z) (% imm0))
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))
283  (cmpl ($ (target-nil-value)) (% temp0))
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 ()
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))
306
307(defx8632lapfunction full-gccount ()
308  (ref-global tenured-area arg_z)
309  (test (% arg_z) (% arg_z))
310  (cmovel (@ (+ (target-nil-value) (x8632::%kernel-global 'gc-count))) (% arg_z))
311  (cmovnel (@ x8632::area.gc-count (% arg_z)) (% arg_z))
312  (single-value-return))
313
314(defx8632lapfunction egc ((arg arg_z))
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 ..."
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)
326  (single-value-return))
327
328(defx8632lapfunction %configure-egc ((e0size 4)
329                                     #|(ra 0)|#
330                                     (e1size arg_y)
331                                     (e2size arg_z))
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))
337
338(defx8632lapfunction purify ()
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))
344
345(defx8632lapfunction impurify ()
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))
351
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
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)
379  (movl ($ (target-nil-value)) (%l arg_z))
380  (single-value-return))
381
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
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
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
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))
407  (unbox-fixnum arg_z imm0)
408  (addl (@ (+ (target-nil-value) (x8632::%kernel-global 'kernel-imports))) (% imm0))
409  (movl (@ (% imm0)) (% imm0))
410  (box-fixnum imm0 arg_z)
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 ()
451  (pop (% temp0))
452  (subl ($ '2) (% nargs))
453  (leal (@ '2 (% esp) (% nargs)) (% imm0))
454  (cmoval (% imm0) (% esp))
455  (movl ($ (target-t-value)) (% arg_z))
456  (push (% temp0))
457  (single-value-return))
458
459(defx8632lapfunction false ()
460  (pop (% temp0))
461  (subl ($ '2) (% nargs))
462  (leal (@ '2 (% esp) (% nargs)) (% imm0))
463  (cmoval (% imm0) (% esp))
464  (movl ($ (target-nil-value)) (% arg_z))
465  (push (% temp0))
466  (single-value-return))
467
468(defx8632lapfunction int3 ()
469  (int ($ 3))
470  (single-value-return))
Note: See TracBrowser for help on using the repository browser.