source: branches/arm/level-0/ARM/arm-utils.lisp @ 13822

Last change on this file since 13822 was 13822, checked in by gb, 9 years ago

%WALK-DYNAMIC-AREA.

File size: 14.5 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL; -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL 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(defarmlapfunction %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  (test-fixnum arg)
24  (mov imm0 arg_z)
25  (bxeq lr)
26  (tst imm0 (:$ #xc0000000))            ; see if result fits in a fixnum, sorta
27  (box-fixnum arg_z imm0)               ; assume it did
28  (bxeq lr)                             ; else arg_z tagged ok, but missing bits
29  (ba .SPmakeu32)         ; put all bits in bignum.
30)
31
32
33
34;;; "areas" are fixnum-tagged and, for the most part, so are their
35;;; contents.
36
37;;; The nilreg-relative global all-areas is a doubly-linked-list header
38;;; that describes nothing.  Its successor describes the current/active
39;;; dynamic heap.  Return a fixnum which "points to" that area, after
40;;; ensuring that the "active" pointers associated with the current thread's
41;;; stacks are correct.
42
43
44
45(defarmlapfunction %normalize-areas ()
46  (let ((address imm0)
47        (temp imm2))
48
49    ;; Update active pointer for vsp area.
50    (ldr address (:@ arm::rcontext (:$ arm::tcr.vs-area)))
51    (str vsp (:@ address (:$ arm::area.active)))
52   
53    ; Update active pointer for SP area
54    (ldr arg_z (:@ arm::rcontext (:$ arm::tcr.cs-area)))
55    (str sp (:@ arg_z (:$ arm::area.active)))
56
57
58    (ref-global arg_z all-areas)
59    (ldr arg_z (:@ arg_z (:$ arm::area.succ)))
60
61    (bx lr)))
62
63(defarmlapfunction %active-dynamic-area ()
64  (ref-global arg_z all-areas)
65  (ldr arg_z (:@ arg_z (:$ arm::area.succ)))
66  (bx lr))
67
68 
69(defarmlapfunction %object-in-stack-area-p ((object arg_y) (area arg_z))
70  (ldr imm0 (:@ area (:$ arm::area.active)))
71  (ldr imm1 (:@ area (:$ arm::area.high)))
72  (mov arg_z (:$ arm::nil-value))
73  (cmp object imm0)
74  (bxlo lr)
75  (cmp object imm1)
76  (bxhs lr)
77  (add arg_z arg_z (:$ arm::t-offset))
78  (bx lr))
79
80(defarmlapfunction %object-in-heap-area-p ((object arg_y) (area arg_z))
81  (ldr imm0 (:@ area (:$ arm::area.low)))
82  (ldr imm1 (:@ area (:$ arm::area.active)))
83  (mov arg_z (:$ arm::nil-value))
84  (cmp object imm0)
85  (bxlo lr)
86  (cmp object imm1)
87  (bxhs lr)
88  (add arg_z arg_z (:$ arm::t-offset))
89  (bx lr))
90
91
92(defarmlapfunction walk-static-area ((a arg_y) (f arg_z))
93  (let ((fun temp0)
94        (obj temp1)
95        (limit temp2)
96        (header imm0)
97        (tag imm1)
98        (subtag imm2))
99    (build-lisp-frame)
100    (mov fun f)
101    (ldr limit (:@ a (:$ arm::area.active)))
102    (ldr obj (:@ a (:$ arm::area.low)))
103    (b @test)
104    @loop
105    (ldr header (:@ obj (:$ 0)))
106    (extract-fulltag tag header)
107    (cmp tag (:$ arm::fulltag-immheader))   
108    (cmpne tag (:$ arm::fulltag-nodeheader))
109    (beq @misc)
110    (add arg_z obj (:$ arm::fulltag-cons))
111    (set-nargs 1)
112    (stmdb (:! vsp) (fun obj limit))
113    (mov nfn fun)
114    (bl .SPFuncall)
115    (ldmia (:! vsp) (fun obj limit))
116    (add obj obj (:$ arm::cons.size))
117    (b @test)
118    @misc
119    (add arg_z obj (:$ arm::fulltag-misc))
120    (stmdb (:! vsp) (fun obj limit))
121    (set-nargs 1)
122    (mov nfn fun)
123    (bl .SPFuncall)
124    (ldmia (:! vsp) (fun obj limit))
125    (ldr header (:@ obj (:$ 0)))
126    (extract-fulltag tag header)
127    (cmp tag (:$ arm::fulltag-nodeheader))
128    (extract-lowbyte subtag header)
129    (bic header header (:$ arm::subtag-mask))
130    (mov header (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift))))
131    (beq @bump)
132    (cmp subtag (:$ arm::max-32-bit-ivector-subtag))
133    (bls @bump)
134    (cmp subtag (:$ arm::max-8-bit-ivector-subtag))
135    (movls header (:lsr header (:$ 2)))
136    (bls @bump)
137    (cmp subtag (:$ arm::max-16-bit-ivector-subtag))
138    (movls header (:lsr header (:$ 1)))
139    (bls @bump)
140    (cmp subtag (:$ arm::subtag-double-float-vector))
141    (movls header (:lsl header (:$ 1)))
142    (bls @bump)
143    (mov header (:lsr header (:$ 2)))
144    (add header header (:$ 7))
145    (mov header (:lsr header (:$ 3)))
146    @bump
147    (add header header (:$ (+ 4 7)))
148    (bic header header (:$ arm::fulltagmask))
149    (add obj obj header)
150    @test
151    (cmp obj limit)
152    (blo @loop)
153    (return-lisp-frame)))
154
155
156
157;;; This walks the active "dynamic" area.  Objects might be moving around
158;;; while we're doing this, so we have to be a lot more careful than we
159;;; are when walking a static area.
160;;; There's the vague notion that we can't take an interrupt when
161;;; "initptr" doesn't equal "freeptr", though what kind of hooks into a
162;;; preemptive scheduler we'd need to enforce this is unclear.  We use
163;;; initptr as an untagged pointer here (and set it to freeptr when we've
164;;; got a tagged pointer to the current object.)
165;;; There are a couple of approaches to termination:
166;;;  a) Allocate a "sentinel" cons, and terminate when we run into it.
167;;;  b) Check the area limit (which is changing if we're consing) and
168;;;     terminate when we hit it.
169;;; (b) loses if the function conses.  (a) conses.  I can't think of anything
170;;; better than (a).
171;;; This, of course, assumes that any GC we're doing does in-place compaction
172;;; (or at least preserves the relative order of objects in the heap.)
173
174(defarmlapfunction %walk-dynamic-area ((a arg_y) (f arg_z))
175  (let ((fun temp0)
176        (obj temp1)
177        (sentinel temp2)
178        (header imm0)
179        (tag imm1)
180        (subtag imm2))
181    (ref-global imm1 tenured-area)   
182    (build-lisp-frame)
183    (mov allocptr (:$ -8))
184    (str allocptr (:@ rcontext (:$ arm::tcr.save-allocbase)))
185    (cmp imm1 (:$ 0))
186    (mov fun f)
187    (movne a imm1)
188    (sub allocptr allocptr (:$ (- arm::cons.size arm::fulltag-cons)))
189    (ldr imm1 (:@ rcontext (:$ arm::tcr.save-allocbase)))
190    (cmp allocptr imm1)
191    (uuo-alloc-trap (:? lo))
192    (mov sentinel allocptr)
193    (bic allocptr allocptr (:$ arm::fulltagmask))
194    (ldr obj (:@ a (:$ arm::area.low)))
195    (b @test)
196    @loop
197    (ldr header (:@ obj (:$ 0)))
198    (extract-fulltag tag header)
199    (cmp tag (:$ arm::fulltag-immheader))   
200    (cmpne tag (:$ arm::fulltag-nodeheader))
201    (beq @misc)
202    (add arg_z obj (:$ arm::fulltag-cons))
203    (cmp arg_z sentinel)
204    (bhs @done)
205    (set-nargs 1)
206    (stmdb (:! vsp) (fun obj sentinel))
207    (mov nfn fun)
208    (bl .SPFuncall)
209    (ldmia (:! vsp) (fun obj sentinel))
210    (add obj obj (:$ arm::cons.size))
211    (b @test)
212    @misc
213    (add arg_z obj (:$ arm::fulltag-misc))
214    (stmdb (:! vsp) (fun obj sentinel))
215    (set-nargs 1)
216    (mov nfn fun)
217    (bl .SPFuncall)
218    (ldmia (:! vsp) (fun obj sentinel))
219    (ldr header (:@ obj (:$ 0)))
220    (extract-fulltag tag header)
221    (cmp tag (:$ arm::fulltag-nodeheader))
222    (extract-lowbyte subtag header)
223    (bic header header (:$ arm::subtag-mask))
224    (mov header (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift))))
225    (beq @bump)
226    (cmp subtag (:$ arm::max-32-bit-ivector-subtag))
227    (bls @bump)
228    (cmp subtag (:$ arm::max-8-bit-ivector-subtag))
229    (movls header (:lsr header (:$ 2)))
230    (bls @bump)
231    (cmp subtag (:$ arm::max-16-bit-ivector-subtag))
232    (movls header (:lsr header (:$ 1)))
233    (bls @bump)
234    (cmp subtag (:$ arm::subtag-double-float-vector))
235    (movls header (:lsl header (:$ 1)))
236    (bls @bump)
237    (mov header (:lsr header (:$ 2)))
238    (add header header (:$ 7))
239    (mov header (:lsr header (:$ 3)))
240    @bump
241    (add header header (:$ (+ 4 7)))
242    (bic header header (:$ arm::fulltagmask))
243    (add obj obj header)
244    @test
245    (cmp obj sentinel)
246    (blo @loop)
247    (uuo-debug-trap)
248    @done
249    (return-lisp-frame)))
250
251
252
253(defun walk-dynamic-area (area func)
254  (with-other-threads-suspended
255      (%walk-dynamic-area area func)))
256
257
258
259(defarmlapfunction %class-of-instance ((i arg_z))
260  (svref arg_z instance.class-wrapper i)
261  (svref arg_z %wrapper-class arg_z)
262  (bx lr))
263
264(defarmlapfunction class-of ((x arg_z))
265  (check-nargs 1)
266  (extract-fulltag imm0 x)
267  (cmp imm0 (:$ arm::fulltag-misc))
268  (beq @misc)
269  (extract-lowbyte imm0 x)
270  (b @done)
271  @misc
272  (extract-subtag imm0 x)
273  @done
274  (mov imm0 (:lsr imm0 (:$ arm::word-shift)))
275  (ldr temp1 (:@ nfn  '*class-table*))
276  (add imm0 imm0 (:$ arm::misc-data-offset))
277  (ldr temp1 (:@ temp1 (:$ arm::symbol.vcell)))
278  (ldr temp0 (:@ temp1 imm0)) ; get entry from table
279  (cmp temp0 'nil)
280  (beq @bad)
281  ;; functionp?
282  (extract-typecode imm1 temp0)
283  (cmp imm1 (:$ arm::subtag-function))
284  (bne @ret)  ; not function - return entry
285  ;; else jump to the fn
286  (set-nargs 1)
287  (mov nfn temp0)
288  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
289  @bad
290  (set-nargs 1)
291  (ldr fname (:@ nfn 'no-class-error))
292  (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
293  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
294  @ret
295  (mov arg_z temp0)  ; return frob from table
296  (bx lr))
297
298(defarmlapfunction full-gccount ()
299  (ref-global arg_z tenured-area)
300  (cmp arg_z (:$ 0))
301  (bne @from-area)
302  (ref-global arg_z gc-count)
303  (bx lr)
304  @from-area
305  (ldr arg_z (:@ arg_z (:$ arm::area.gc-count)))
306  (bx lr))
307
308
309#+notyet                                ;trap encoding
310(progn
311(defarmlapfunction gc ()
312  (check-nargs 0)
313  (li imm0 arch::gc-trap-function-gc)
314  (trlgei allocptr 0)
315  (li arg_z (target-nil-value))
316  (bx lr))
317
318
319(defarmlapfunction egc ((arg arg_z))
320  "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return
321the previous enabled status. Although this function is thread-safe (in
322the sense that calls to it are serialized), it doesn't make a whole lot
323of sense to be turning the EGC on and off from multiple threads ..."
324  (check-nargs 1)
325  (subi imm1 arg nil)
326  (li imm0 arch::gc-trap-function-egc-control)
327  (trlgei allocptr 0)
328  (bx lr))
329
330
331
332(defarmlapfunction %configure-egc ((e0size arg_x)
333                                   (e1size arg_y)
334                                   (e2size arg_z))
335  (check-nargs 3)
336  (li imm0 arch::gc-trap-function-configure-egc)
337  (trlgei allocptr 0)
338  (bx lr))
339
340(defarmlapfunction purify ()
341  (li imm0 arch::gc-trap-function-purify)
342  (trlgei allocptr 0)
343  (li arg_z nil)
344  (bx lr))
345
346
347(defarmlapfunction impurify ()
348  (li imm0 arch::gc-trap-function-impurify)
349  (trlgei allocptr 0)
350  (li arg_z nil)
351  (bx lr))
352
353(defarmlapfunction lisp-heap-gc-threshold ()
354  "Return the value of the kernel variable that specifies the amount
355of free space to leave in the heap after full GC."
356  (check-nargs 0)
357  (li imm0 arch::gc-trap-function-get-lisp-heap-threshold)
358  (trlgei allocptr 0)
359  #+arm32-target
360  (ba .SPmakeu32)
361  #+arm64-target
362  (ba .SPmakeu64))
363
364(defarmlapfunction set-lisp-heap-gc-threshold ((new arg_z))
365  "Set the value of the kernel variable that specifies the amount of free
366space to leave in the heap after full GC to new-value, which should be a
367non-negative fixnum. Returns the value of that kernel variable (which may
368be somewhat larger than what was specified)."
369  (check-nargs 1)
370  (mflr loc-pc)
371  #+arm32-target
372  (bla .SPgetu32)
373  #+arm64-target
374  (bla .SPgetu64)
375  (mtlr loc-pc)
376  (mov imm1 imm0)
377  (li imm0 arch::gc-trap-function-set-lisp-heap-threshold)
378  (trlgei allocptr 0)
379  #+arm32-target
380  (ba .SPmakeu32)
381  #+arm64-target
382  (ba .SPmakeu64))
383
384
385(defarmlapfunction use-lisp-heap-gc-threshold ()
386  "Try to grow or shrink lisp's heap space, so that the free space is(approximately) equal to the current heap threshold. Return NIL"
387  (check-nargs 0) 
388  (li imm0 arch::gc-trap-function-use-lisp-heap-threshold)
389  (trlgei allocptr 0)
390  (li arg_z nil)
391  (bx lr))
392
393
394(defarmlapfunction freeze ()
395  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
396  (check-nargs 0)
397  (li imm0 arch::gc-trap-function-freeze)
398  (trlgei allocptr 0)
399  #+64-bit-target
400  (ba .SPmakeu64)
401  #+32-bit-target
402  (ba .SPmakeu32))
403
404(defarmlapfunction flash-freeze ()
405  "Like FREEZE, but don't GC first."
406  (check-nargs 0)
407  (li imm0 arch::gc-trap-function-flash-freeze)
408  (trlgei allocptr 0)
409  #+64-bit-target
410  (ba .SPmakeu64)
411  #+32-bit-target
412  (ba .SPmakeu32))
413
414(defun %watch (uvector)
415  (declare (ignore uvector))
416  (error "watching objects not supported on ARM yet"))
417
418(defun %unwatch (watched new)
419  (declare (ignore watched new))
420  (error "watching objects not supported on ARM yet"))
421
422;;; Make a list.  This can be faster than doing so by doing CONS
423;;; repeatedly, since the latter strategy might triger the GC several
424;;; times if N is large.
425(defarmlapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
426  (check-nargs 2)
427  (save-lisp-context)
428  (uuo_interr arch::error-allocate-list rzero)
429  (vpush arg_z)
430  (vpush arg_y)
431  (set-nargs 2)
432  (ba .SPnvalret))
433 
434(defarmlapfunction %ensure-static-conses ()
435  (check-nargs 0)
436  (li imm0 arch::gc-trap-function-ensure-static-conses)
437  (trlgei allocptr 0)
438  (li arg_z nil)
439  (bx lr))
440)
441
442;;; offset is a fixnum, one of the arm::kernel-import-xxx constants.
443;;; Returns that kernel import, a fixnum.
444(defarmlapfunction %kernel-import ((offset arg_z))
445  (ref-global imm0 kernel-imports)
446  (ldr imm0 (:@ imm0 (:asr arg_z (:$ arm::fixnumshift))))
447  (box-fixnum arg_z imm0)
448  (bx lr))
449
450(defarmlapfunction %get-unboxed-ptr ((macptr arg_z))
451  (macptr-ptr imm0 arg_z)
452  (ldr arg_z (:@ imm0 (:$ 0)))
453  (bx lr))
454
455
456(defarmlapfunction %revive-macptr ((p arg_z))
457  (mov imm0 (:$ arm::subtag-macptr))
458  (strb imm0 (:@ p (:$ arm::misc-subtag-offset)))
459  (bx lr))
460
461(defarmlapfunction %macptr-type ((p arg_z))
462  (check-nargs 1)
463  (trap-unless-xtype= p arm::subtag-macptr)
464  (svref imm0 arm::macptr.type-cell p)
465  (box-fixnum arg_z imm0)
466  (bx lr))
467 
468(defarmlapfunction %macptr-domain ((p arg_z))
469  (check-nargs 1)
470  (trap-unless-xtype= p arm::subtag-macptr)
471  (svref imm0 arm::macptr.domain-cell p)
472  (box-fixnum arg_z imm0)
473  (bx lr))
474
475(defarmlapfunction %set-macptr-type ((p arg_y) (new arg_z))
476  (check-nargs 2)
477  (unbox-fixnum imm1 new)
478  (trap-unless-xtype= p arm::subtag-macptr)
479  (svset imm1 arm::macptr.type-cell p)
480  (bx lr))
481
482(defarmlapfunction %set-macptr-domain ((p arg_y) (new arg_z))
483  (check-nargs 2)
484  (unbox-fixnum imm1 new)
485  (trap-unless-xtype= p arm::subtag-macptr)
486  (svset imm1 arm::macptr.domain-cell p)
487  (bx lr))
488
489(defarmlapfunction true ()
490  (:arglist (&rest ignore))
491  (cmp nargs '3)
492  (mov arg_z (:$ arm::nil-value))
493  (add arg_z arg_z (:$ arm::t-offset))
494  (bxls lr)
495  (sub imm0 nargs '3)
496  (add vsp vsp imm0)
497  (bx lr))
498
499(defarmlapfunction false ()
500  (:arglist (&rest ignore))
501  (cmp nargs '3)
502  (mov arg_z (:$ arm::nil-value))
503  (bxls lr)
504  (sub imm0 nargs '3)
505  (add vsp vsp imm0)
506  (bx lr))
507
508
509
510;;; end
Note: See TracBrowser for help on using the repository browser.