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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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