source: branches/win64/level-0/X86/x86-utils.lisp @ 8649

Last change on this file since 8649 was 8649, checked in by gb, 12 years ago

Use (:rcontext tcr-field) syntax to reference TCR fields.
Don't use SAVE3 (was used for debugging of heap-walking code; might
be used in %%APPLY-IN-FRAME-PROTO if caller sets it.)

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