source: trunk/source/level-0/X86/x86-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.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.6 KB
Line 
1; -*- Mode: Lisp; Package: CCL; -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18(in-package "CCL")
19#+x8664-target
20(progn
21
22(defx86lapfunction %address-of ((arg arg_z))
23  ;; %address-of a fixnum is a fixnum, just for spite.
24  ;; %address-of anything else is the address of that thing as an integer.
25  (testb ($ x8664::fixnummask) (%b arg))
26  (je @done)
27  (movq (% arg) (% imm0))
28  (jmp-subprim .SPmakeu64)
29  @done
30  (single-value-return))
31
32;;; "areas" are fixnum-tagged and, for the most part, so are their
33;;; contents.
34
35;;; The nilreg-relative global all-areas is a doubly-linked-list header
36;;; that describes nothing.  Its successor describes the current/active
37;;; dynamic heap.  Return a fixnum which "points to" that area, after
38;;; ensuring that the "active" pointers associated with the current thread's
39;;; stacks are correct.
40
41
42
43(defx86lapfunction %normalize-areas ()
44  (let ((address temp0)
45        (temp temp1))
46
47    ; update active pointer for tsp area.
48    (movq (:rcontext x8664::tcr.ts-area) (% address))
49    (movq (:rcontext x8664::tcr.save-tsp) (% temp))
50    (movq (% temp) (@ x8664::area.active (% address)))
51   
52    ;; Update active pointer for vsp area.
53    (movq (:rcontext x8664::tcr.vs-area) (% address))
54    (movq (% rsp) (@ x8664::area.active (% address)))
55
56    (ref-global all-areas arg_z)
57    (movq (@ x8664::area.succ (% arg_z)) (% arg_z))
58
59    (single-value-return)))
60
61(defx86lapfunction %active-dynamic-area ()
62  (ref-global all-areas arg_z)
63  (movq (@ x8664::area.succ (% arg_z)) (% arg_z))
64  (single-value-return))
65
66 
67(defx86lapfunction %object-in-stack-area-p ((object arg_y) (area arg_z))
68  (movq (@ x8664::area.active (% area)) (% imm0))
69  (movq (@ x8664::area.high (% area)) (% imm1))
70  (rcmp (% object) (% imm0))
71  (movq ($ nil) (% arg_z))
72  (movq ($ t) (% imm0))
73  (jb @done)
74  (rcmp (% object) (% imm1))
75  (cmovbq (% imm0) (% arg_z))
76  @done
77  (single-value-return))
78
79(defx86lapfunction %object-in-heap-area-p ((object arg_y) (area arg_z))
80  (rcmp (% object) (@ x8664::area.low (% area)))
81  (setae (%b imm0))
82  (rcmp (% object) (@ x8664::area.low (% area)))
83  (setb (%b imm1))
84  (andb (% imm1.b) (% imm0.b))
85  (andl ($ x8664::t-offset) (%l imm0))
86  (lea (@ (target-nil-value) (% imm0)) (% arg_z))
87  (single-value-return))
88
89
90
91
92(defx86lapfunction walk-static-area ((a arg_y) (f arg_z))
93  (let ((fun save0)
94        (obj save1)
95        (limit save2))
96    (save-simple-frame)
97    (push (% fun))
98    (push (% obj))
99    (push (% limit))
100    (movq (% f) (% fun))
101    (movq (@ x8664::area.active (% a)) (% limit))
102    (movq (@ x8664::area.low (% a)) (% obj))
103    (jmp @test)
104    @loop
105    (movb (@ (% obj)) (% imm0.b))
106    (andb ($ x8664::fulltagmask) (% imm0.b))
107    (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b))
108    (je @misc)
109    (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b))
110    (je @misc)
111    (cmpb ($ x8664::fulltag-immheader-0) (% imm0.b))
112    (je @misc)
113    (cmpb ($ x8664::fulltag-immheader-2) (% imm0.b))
114    (je @misc)
115    (cmpb ($ x8664::fulltag-immheader-1) (% imm0.b))
116    (jne @cons)
117    @misc
118    (lea (@ x8664::fulltag-misc (% obj)) (% obj))
119    (movq (% obj) (% arg_z))
120    (set-nargs 1)
121    (:talign 4)
122    (call (% fun))
123    (recover-fn-from-rip)
124    (getvheader obj imm1)
125    (movb (% imm1.b) (% imm0.b))
126    (andb ($ x8664::fulltagmask) (% imm0.b))
127    (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b))
128    (je @64)
129    (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b))
130    (je @64)
131    (cmpb ($ x8664::ivector-class-64-bit) (% imm0.b))
132    (jne @not64)
133    @64
134    (shrq ($ x8664::num-subtag-bits) (% imm1))
135    (shlq ($ x8664::word-shift) (% imm1))
136    (jmp @uvector-next)
137    @not64
138    (cmpb ($ x8664::ivector-class-32-bit) (% imm0.b))
139    (jne @not32)
140    (shrq ($ x8664::num-subtag-bits) (% imm1))
141    (shlq ($ 2) (% imm1))
142    (jmp @uvector-next)
143    @not32
144    (cmpb ($ (- x8664::subtag-bit-vector 256)) (% imm1.b))
145    (jne @not-bit)
146    (shrq ($ x8664::num-subtag-bits) (% imm1))
147    (addq ($ 7) (% imm1))
148    (shrq ($ 3) (% imm1))
149    (jmp @uvector-next)
150    @not-bit
151    (rcmpb (% imm1.b) ($ (- x8664::min-8-bit-ivector-subtag 256)))
152    (jb @16)
153    (shrq ($ x8664::num-subtag-bits) (% imm1))
154    (jmp @uvector-next)
155    @16
156    (shrq ($ x8664::num-subtag-bits) (% imm1))
157    (shlq ($ 1) (% imm1))
158    (jmp @uvector-next)
159    @cons
160    (addq ($ x8664::fulltag-cons) (% obj))
161    (movq (% obj) (% arg_z))
162    (set-nargs 1)
163    (:talign 4)
164    (call (% fun))
165    (recover-fn-from-rip)
166    (addq ($ (- x8664::cons.size x8664::fulltag-cons)) (% obj))
167    (jmp @test)
168    ;; size of OBJ in bytes (without header or alignment padding)
169    ;; in imm1.
170    @uvector-next
171    (addq ($ (+ x8664::node-size (1- x8664::dnode-size))) (% imm1))
172    (andb ($ (lognot (1- x8664::dnode-size))) (% imm1.b))
173    (lea (@ (- x8664::fulltag-misc) (% obj) (% imm1)) (% obj))
174    @test
175    (cmpq (% limit) (% obj))
176    (jb @loop)
177    (pop (% limit))
178    (pop (% obj))
179    (pop (% fun))
180    (movl ($ (target-nil-value)) (% arg_z.l))
181    (restore-simple-frame)
182    (single-value-return)))
183
184
185
186;;; This walks the active "dynamic" area.  Objects might be moving around
187;;; while we're doing this, so we have to be a lot more careful than we
188;;; are when walking a static area.
189;;; There are a couple of approaches to termination:
190;;;  a) Allocate a "sentinel" cons, and terminate when we run into it.
191;;;  b) Check the area limit (which is changing if we're consing) and
192;;;     terminate when we hit it.
193;;; (b) loses if the function conses.  (a) conses.  I can't think of anything
194;;; better than (a).
195;;; This, of course, assumes that any GC we're doing does in-place compaction
196;;; (or at least preserves the relative order of objects in the heap.)
197
198(defx86lapfunction %walk-dynamic-area ((a arg_y) (f arg_z))
199  (let ((fun save0)
200        (obj save1)
201        (limit save2))
202    (save-simple-frame)
203    (push (% fun))
204    (push (% obj))
205    (push (% limit))
206    (movq (% f) (% fun))
207    (ref-global tenured-area a)
208    (movq (@ x8664::area.low (% a)) (% obj))
209    (subq ($ (- x8664::cons.size x8664::fulltag-cons))
210          (:rcontext x8664::tcr.save-allocptr))
211    (movq (:rcontext x8664::tcr.save-allocptr) (% allocptr))
212    (cmpq (:rcontext x8664::tcr.save-allocbase) (% allocptr))
213    (jg @ok)
214    (uuo-alloc)
215    @ok
216    (andb ($ (lognot x8664::fulltagmask))
217          (:rcontext x8664::tcr.save-allocptr))
218    (movq (% allocptr) (% limit))
219    (jmp @test)
220    @loop
221    (movb (@ (% obj)) (% imm0.b))
222    (andb ($ x8664::fulltagmask) (% imm0.b))
223    (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b))
224    (je @misc)
225    (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b))
226    (je @misc)
227    (cmpb ($ x8664::fulltag-immheader-0) (% imm0.b))
228    (je @misc)
229    (cmpb ($ x8664::fulltag-immheader-2) (% imm0.b))
230    (je @misc)
231    (cmpb ($ x8664::fulltag-immheader-1) (% imm0.b))
232    (jne @cons)
233    @misc
234    (lea (@ x8664::fulltag-misc (% obj)) (% obj))
235    (movq (% obj) (% arg_z))
236    (set-nargs 1)
237    (:talign 4)
238    (call (% fun))
239    (recover-fn-from-rip)
240    (getvheader obj imm1)
241    (movb (% imm1.b) (% imm0.b))
242    (andb ($ x8664::fulltagmask) (% imm0.b))
243    (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b))
244    (je @64)
245    (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b))
246    (je @64)
247    (cmpb ($ x8664::ivector-class-64-bit) (% imm0.b))
248    (jne @not64)
249    @64
250    (shrq ($ x8664::num-subtag-bits) (% imm1))
251    (shlq ($ x8664::word-shift) (% imm1))
252    (jmp @uvector-next)
253    @not64
254    (cmpb ($ x8664::ivector-class-32-bit) (% imm0.b))
255    (jne @not32)
256    (shrq ($ x8664::num-subtag-bits) (% imm1))
257    (shlq ($ 2) (% imm1))
258    (jmp @uvector-next)
259    @not32
260    (cmpb ($ (- x8664::subtag-bit-vector 256)) (% imm1.b))
261    (jne @not-bit)
262    (shrq ($ x8664::num-subtag-bits) (% imm1))
263    (addq ($ 7) (% imm1))
264    (shrq ($ 3) (% imm1))
265    (jmp @uvector-next)
266    @not-bit
267    (rcmpb (% imm1.b) ($ (- x8664::min-8-bit-ivector-subtag 256)))
268    (jb @16)
269    (shrq ($ x8664::num-subtag-bits) (% imm1))
270    (jmp @uvector-next)
271    @16
272    (shrq ($ x8664::num-subtag-bits) (% imm1))
273    (shlq ($ 1) (% imm1))
274    (jmp @uvector-next)
275    @cons
276    (addq ($ x8664::fulltag-cons) (% obj))
277    (cmpq (% obj) (% limit))
278    (movq (% obj) (% arg_z))
279    (je @done)
280    (set-nargs 1)
281    (:talign 4)
282    (call (% fun))
283    (recover-fn-from-rip)
284    (addq ($ (- x8664::cons.size x8664::fulltag-cons)) (% obj))
285    (jmp @test)
286    ;; size of OBJ in bytes (without header or alignment padding)
287    ;; in imm1.
288    @uvector-next
289    (addq ($ (+ x8664::node-size (1- x8664::dnode-size))) (% imm1))
290    (andb ($ (lognot (1- x8664::dnode-size))) (% imm1.b))
291    (lea (@ (- x8664::fulltag-misc) (% obj) (% imm1)) (% obj))
292    @test
293    (cmpq (% limit) (% obj))
294    (jb @loop)
295    @done
296    (pop (% limit))
297    (pop (% obj))
298    (pop (% fun))
299    (movl ($ (target-nil-value)) (% arg_z.l))
300    (restore-simple-frame)
301    (single-value-return)))
302
303(defun walk-dynamic-area (area func)
304  (with-other-threads-suspended
305      (%walk-dynamic-area area func)))
306
307
308
309(defx86lapfunction %class-of-instance ((i arg_z))
310  (svref i instance.class-wrapper arg_z)
311  (svref arg_z %wrapper-class arg_z)
312  (single-value-return))
313
314(defx86lapfunction class-of ((x arg_z))
315  (check-nargs 1)
316  (movw ($ (logior (ash 1 x8664::tag-list)
317                   (ash 1 x8664::tag-imm-1)))
318        (%w imm1))
319  (extract-lisptag x imm0)
320  (btw (% imm0.w) (% imm1.w))
321  (cmovbl (% arg_z.l) (% imm0.l))
322  (movq (@ '*class-table* (% fn)) (% temp1))
323  (cmpb ($ x8664::tag-misc) (% imm0.b))
324  (jne @have-tag)
325  (extract-subtag x imm0)
326  @have-tag
327  (movq (@ x8664::symbol.vcell (% temp1)) (% temp1))
328  (movzbl (% imm0.b) (% imm0.l))
329  (movq (@ x8664::misc-data-offset (% temp1) (% imm0) 8) (% temp0))
330  (cmpb ($ x8664::fulltag-nil) (%b temp0))
331  (je @bad)
332  (extract-fulltag temp0 imm0)
333  (cmpb ($ x8664::fulltag-function) (%b imm0))
334  (jne @ret)
335  (set-nargs 1)
336  (jmp (% temp0))
337  @bad
338  (load-constant no-class-error fname)
339  (set-nargs 1)
340  (jmp  (@ x8664::symbol.fcell (% fname)))
341  @ret
342  (movq (% temp0) (% arg_z))  ; return frob from table
343  (single-value-return))
344
345(defx86lapfunction full-gccount ()
346  (ref-global tenured-area arg_z)
347  (testq (% arg_z) (% arg_z))
348  (cmoveq (@ (+ (target-nil-value) (x8664::%kernel-global 'gc-count))) (% arg_z))
349  (cmovneq (@ x8664::area.gc-count (% arg_z)) (% arg_z))
350  (single-value-return))
351
352
353(defx86lapfunction gc ()
354  (check-nargs 0)
355  (movq ($ arch::gc-trap-function-gc) (% imm0))
356  (uuo-gc-trap)
357  (movq ($ nil) (% arg_z))
358  (single-value-return))
359
360
361(defx86lapfunction egc ((arg arg_z))
362  "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return
363the previous enabled status. Although this function is thread-safe (in
364the sense that calls to it are serialized), it doesn't make a whole lot
365of sense to be turning the EGC on and off from multiple threads ..."
366  (check-nargs 1)
367  (clrq imm1)
368  (cmp-reg-to-nil arg)
369  (setne (% imm1.b))
370  (movq ($ arch::gc-trap-function-egc-control) (% imm0))
371  (uuo-gc-trap)
372  (single-value-return))
373
374
375
376
377(defx86lapfunction %configure-egc ((e0size arg_x)
378                                   (e1size arg_y)
379                                   (e2size arg_z))
380  (check-nargs 3)
381  (movq ($ arch::gc-trap-function-configure-egc) (% imm0))
382  (uuo-gc-trap)
383  (single-value-return))
384
385(defx86lapfunction purify ()
386  (check-nargs 0)
387  (movq ($ arch::gc-trap-function-purify) (% imm0))
388  (uuo-gc-trap)
389  (movq ($ nil) (% arg_z))
390  (single-value-return))
391
392
393(defx86lapfunction impurify ()
394  (check-nargs 0)
395  (movq ($ arch::gc-trap-function-impurify) (% imm0))
396  (uuo-gc-trap)
397  (movq ($ nil) (% arg_z))
398  (single-value-return))
399
400
401(defx86lapfunction lisp-heap-gc-threshold ()
402  "Return the value of the kernel variable that specifies the amount
403of free space to leave in the heap after full GC."
404  (check-nargs 0)
405  (movq ($ arch::gc-trap-function-get-lisp-heap-threshold) (% imm0))
406  (uuo-gc-trap)
407  #+x8632-target
408  (jmp-subprim .SPmakeu32)
409  #+x8664-target
410  (jmp-subprim .SPmakeu64))
411
412(defx86lapfunction set-lisp-heap-gc-threshold ((new arg_z))
413  "Set the value of the kernel variable that specifies the amount of free
414space to leave in the heap after full GC to new-value, which should be a
415non-negative fixnum. Returns the value of that kernel variable (which may
416be somewhat larger than what was specified)."
417  (check-nargs 1)
418  (save-simple-frame)
419  (call-subprim .SPgetu64)
420  (movq (% imm0) (% imm1))
421  (movq ($ arch::gc-trap-function-set-lisp-heap-threshold) (% imm0))
422  (uuo-gc-trap)
423  (restore-simple-frame)
424  (jmp-subprim .SPmakeu64))
425
426
427(defx86lapfunction use-lisp-heap-gc-threshold ()
428  "Try to grow or shrink lisp's heap space, so that the free space is (approximately) equal to the current heap threshold. Return NIL"
429  (check-nargs 0) 
430  (movq ($ arch::gc-trap-function-use-lisp-heap-threshold) (% imm0))
431  (uuo-gc-trap)
432  (movl ($ (target-nil-value)) (%l arg_z))
433  (single-value-return))
434
435(defx86lapfunction freeze ()
436  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
437  (movl ($ arch::gc-trap-function-freeze) (% imm0.l))
438  (uuo-gc-trap)
439  (jmp-subprim .SPmakeu64))
440
441(defx86lapfunction flash-freeze ()
442  "Like FREEZE, without the GC."
443  (movl ($ arch::gc-trap-function-flash-freeze) (% imm0.l))
444  (uuo-gc-trap)
445  (jmp-subprim .SPmakeu64))
446
447(defx86lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
448  (check-nargs 2)
449  (save-simple-frame)
450  (ud2a)
451  (:byte 10)
452  (push (% arg_z))
453  (push (% allocptr))
454  (set-nargs 2)
455  (jmp-subprim .SPnvalret))
456
457 
458
459
460;;; offset is a fixnum, one of the x8664::kernel-import-xxx constants.
461;;; Returns that kernel import, a fixnum.
462(defx86lapfunction %kernel-import ((offset arg_z))
463  (ref-global kernel-imports imm0)
464  (unbox-fixnum arg_z imm1)
465  (movq (@ (% imm0) (% imm1)) (% imm0))
466  (box-fixnum imm0 arg_z)
467  (single-value-return))
468
469(defx86lapfunction %get-unboxed-ptr ((macptr arg_z))
470  (macptr-ptr arg_z imm0)
471  (movq (@ (% imm0)) (% arg_z))
472  (single-value-return))
473
474
475(defx86lapfunction %revive-macptr ((p arg_z))
476  (movb ($ x8664::subtag-macptr) (@ x8664::misc-subtag-offset (% p)))
477  (single-value-return))
478
479(defx86lapfunction %macptr-type ((p arg_z))
480  (check-nargs 1)
481  (trap-unless-typecode= p x8664::subtag-macptr)
482  (svref p x8664::macptr.type-cell imm0)
483  (box-fixnum imm0 arg_z)
484  (single-value-return))
485 
486(defx86lapfunction %macptr-domain ((p arg_z))
487  (check-nargs 1)
488  (trap-unless-typecode= p x8664::subtag-macptr)
489  (svref p x8664::macptr.domain-cell imm0)
490  (box-fixnum imm0 arg_z)
491  (single-value-return))
492
493(defx86lapfunction %set-macptr-type ((p arg_y) (new arg_z))
494  (check-nargs 2)
495  (unbox-fixnum new imm1)
496  (trap-unless-typecode= p x8664::subtag-macptr)
497  (svset p x8664::macptr.type-cell imm1)
498  (single-value-return))
499
500(defx86lapfunction %set-macptr-domain ((p arg_y) (new arg_z))
501  (check-nargs 2)
502  (unbox-fixnum new imm1)
503  (trap-unless-typecode= p x8664::subtag-macptr)
504  (svset p x8664::macptr.domain-cell imm1)
505  (single-value-return))
506
507(defx86lapfunction true ()
508  (pop (% ra0))
509  (subq ($ '3) (% nargs.q))
510  (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0))
511  (cmovaq (% imm0) (% rsp))
512  (movl ($ (target-t-value)) (%l arg_z))
513  (push (% ra0))
514  (single-value-return))
515
516(defx86lapfunction false ()
517  (pop (% ra0))
518  (subq ($ '3) (% nargs.q))
519  (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0))
520  (cmovaq (% imm0) (% rsp))
521  (movl ($ (target-nil-value)) (%l arg_z))
522  (push (% ra0))
523  (single-value-return))
524
525
526
527;;; end
528) ; #+x8664-target
Note: See TracBrowser for help on using the repository browser.