source: branches/x8664-call/ccl/level-0/X86/x86-utils.lisp @ 6303

Last change on this file since 6303 was 6303, checked in by gb, 15 years ago

recover-fn-from-rip.

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