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

Last change on this file since 13839 was 13839, checked in by gb, 10 years ago

%WALK-DYNAMIC-AREA: current object can move, so keep it tagged.

File size: 14.6 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 temp1)
176        (obj temp0)
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) (arg_z fun sentinel))
207    (mov nfn fun)
208    (bl .SPFuncall)
209    (ldmia (:! vsp) (obj fun sentinel))
210    (add obj obj (:$ arm::cons.size))
211    (b @test)
212    @misc
213    (add arg_z obj (:$ arm::fulltag-misc))
214    (stmdb (:! vsp) (arg_z fun sentinel))
215    (set-nargs 1)
216    (mov nfn fun)
217    (bl .SPFuncall)
218    (ldmia (:! vsp) (obj fun sentinel))
219    (add obj obj (:$ arm::fulltag-misc))
220    (ldr header (:@ obj (:$ 0)))
221    (extract-fulltag tag header)
222    (cmp tag (:$ arm::fulltag-nodeheader))
223    (extract-lowbyte subtag header)
224    (bic header header (:$ arm::subtag-mask))
225    (mov header (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift))))
226    (beq @bump)
227    (cmp subtag (:$ arm::max-32-bit-ivector-subtag))
228    (bls @bump)
229    (cmp subtag (:$ arm::max-8-bit-ivector-subtag))
230    (movls header (:lsr header (:$ 2)))
231    (bls @bump)
232    (cmp subtag (:$ arm::max-16-bit-ivector-subtag))
233    (movls header (:lsr header (:$ 1)))
234    (bls @bump)
235    (cmp subtag (:$ arm::subtag-double-float-vector))
236    (movls header (:lsl header (:$ 1)))
237    (bls @bump)
238    (mov header (:lsr header (:$ 2)))
239    (add header header (:$ 7))
240    (mov header (:lsr header (:$ 3)))
241    @bump
242    (add header header (:$ (+ 4 7)))
243    (bic header header (:$ arm::fulltagmask))
244    (add obj obj header)
245    @test
246    (cmp obj sentinel)
247    (blo @loop)
248    (uuo-debug-trap)
249    @done
250    (return-lisp-frame)))
251
252
253
254(defun walk-dynamic-area (area func)
255  (with-other-threads-suspended
256      (%walk-dynamic-area area func)))
257
258
259
260(defarmlapfunction %class-of-instance ((i arg_z))
261  (svref arg_z instance.class-wrapper i)
262  (svref arg_z %wrapper-class arg_z)
263  (bx lr))
264
265(defarmlapfunction class-of ((x arg_z))
266  (check-nargs 1)
267  (extract-fulltag imm0 x)
268  (cmp imm0 (:$ arm::fulltag-misc))
269  (beq @misc)
270  (extract-lowbyte imm0 x)
271  (b @done)
272  @misc
273  (extract-subtag imm0 x)
274  @done
275  (mov imm0 (:lsr imm0 (:$ arm::word-shift)))
276  (ldr temp1 (:@ nfn  '*class-table*))
277  (add imm0 imm0 (:$ arm::misc-data-offset))
278  (ldr temp1 (:@ temp1 (:$ arm::symbol.vcell)))
279  (ldr temp0 (:@ temp1 imm0)) ; get entry from table
280  (cmp temp0 'nil)
281  (beq @bad)
282  ;; functionp?
283  (extract-typecode imm1 temp0)
284  (cmp imm1 (:$ arm::subtag-function))
285  (bne @ret)  ; not function - return entry
286  ;; else jump to the fn
287  (set-nargs 1)
288  (mov nfn temp0)
289  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
290  @bad
291  (set-nargs 1)
292  (ldr fname (:@ nfn 'no-class-error))
293  (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
294  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
295  @ret
296  (mov arg_z temp0)  ; return frob from table
297  (bx lr))
298
299(defarmlapfunction full-gccount ()
300  (ref-global arg_z tenured-area)
301  (cmp arg_z (:$ 0))
302  (bne @from-area)
303  (ref-global arg_z gc-count)
304  (bx lr)
305  @from-area
306  (ldr arg_z (:@ arg_z (:$ arm::area.gc-count)))
307  (bx lr))
308
309
310#+notyet                                ;trap encoding
311(progn
312(defarmlapfunction gc ()
313  (check-nargs 0)
314  (li imm0 arch::gc-trap-function-gc)
315  (trlgei allocptr 0)
316  (li arg_z (target-nil-value))
317  (bx lr))
318
319
320(defarmlapfunction egc ((arg arg_z))
321  "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return
322the previous enabled status. Although this function is thread-safe (in
323the sense that calls to it are serialized), it doesn't make a whole lot
324of sense to be turning the EGC on and off from multiple threads ..."
325  (check-nargs 1)
326  (subi imm1 arg nil)
327  (li imm0 arch::gc-trap-function-egc-control)
328  (trlgei allocptr 0)
329  (bx lr))
330
331
332
333(defarmlapfunction %configure-egc ((e0size arg_x)
334                                   (e1size arg_y)
335                                   (e2size arg_z))
336  (check-nargs 3)
337  (li imm0 arch::gc-trap-function-configure-egc)
338  (trlgei allocptr 0)
339  (bx lr))
340
341(defarmlapfunction purify ()
342  (li imm0 arch::gc-trap-function-purify)
343  (trlgei allocptr 0)
344  (li arg_z nil)
345  (bx lr))
346
347
348(defarmlapfunction impurify ()
349  (li imm0 arch::gc-trap-function-impurify)
350  (trlgei allocptr 0)
351  (li arg_z nil)
352  (bx lr))
353
354(defarmlapfunction lisp-heap-gc-threshold ()
355  "Return the value of the kernel variable that specifies the amount
356of free space to leave in the heap after full GC."
357  (check-nargs 0)
358  (li imm0 arch::gc-trap-function-get-lisp-heap-threshold)
359  (trlgei allocptr 0)
360  #+arm32-target
361  (ba .SPmakeu32)
362  #+arm64-target
363  (ba .SPmakeu64))
364
365(defarmlapfunction set-lisp-heap-gc-threshold ((new arg_z))
366  "Set the value of the kernel variable that specifies the amount of free
367space to leave in the heap after full GC to new-value, which should be a
368non-negative fixnum. Returns the value of that kernel variable (which may
369be somewhat larger than what was specified)."
370  (check-nargs 1)
371  (mflr loc-pc)
372  #+arm32-target
373  (bla .SPgetu32)
374  #+arm64-target
375  (bla .SPgetu64)
376  (mtlr loc-pc)
377  (mov imm1 imm0)
378  (li imm0 arch::gc-trap-function-set-lisp-heap-threshold)
379  (trlgei allocptr 0)
380  #+arm32-target
381  (ba .SPmakeu32)
382  #+arm64-target
383  (ba .SPmakeu64))
384
385
386(defarmlapfunction use-lisp-heap-gc-threshold ()
387  "Try to grow or shrink lisp's heap space, so that the free space is(approximately) equal to the current heap threshold. Return NIL"
388  (check-nargs 0) 
389  (li imm0 arch::gc-trap-function-use-lisp-heap-threshold)
390  (trlgei allocptr 0)
391  (li arg_z nil)
392  (bx lr))
393
394
395(defarmlapfunction freeze ()
396  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
397  (check-nargs 0)
398  (li imm0 arch::gc-trap-function-freeze)
399  (trlgei allocptr 0)
400  #+64-bit-target
401  (ba .SPmakeu64)
402  #+32-bit-target
403  (ba .SPmakeu32))
404
405(defarmlapfunction flash-freeze ()
406  "Like FREEZE, but don't GC first."
407  (check-nargs 0)
408  (li imm0 arch::gc-trap-function-flash-freeze)
409  (trlgei allocptr 0)
410  #+64-bit-target
411  (ba .SPmakeu64)
412  #+32-bit-target
413  (ba .SPmakeu32))
414
415(defun %watch (uvector)
416  (declare (ignore uvector))
417  (error "watching objects not supported on ARM yet"))
418
419(defun %unwatch (watched new)
420  (declare (ignore watched new))
421  (error "watching objects not supported on ARM yet"))
422
423;;; Make a list.  This can be faster than doing so by doing CONS
424;;; repeatedly, since the latter strategy might triger the GC several
425;;; times if N is large.
426(defarmlapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
427  (check-nargs 2)
428  (save-lisp-context)
429  (uuo_interr arch::error-allocate-list rzero)
430  (vpush arg_z)
431  (vpush arg_y)
432  (set-nargs 2)
433  (ba .SPnvalret))
434 
435(defarmlapfunction %ensure-static-conses ()
436  (check-nargs 0)
437  (li imm0 arch::gc-trap-function-ensure-static-conses)
438  (trlgei allocptr 0)
439  (li arg_z nil)
440  (bx lr))
441)
442
443;;; offset is a fixnum, one of the arm::kernel-import-xxx constants.
444;;; Returns that kernel import, a fixnum.
445(defarmlapfunction %kernel-import ((offset arg_z))
446  (ref-global imm0 kernel-imports)
447  (ldr imm0 (:@ imm0 (:asr arg_z (:$ arm::fixnumshift))))
448  (box-fixnum arg_z imm0)
449  (bx lr))
450
451(defarmlapfunction %get-unboxed-ptr ((macptr arg_z))
452  (macptr-ptr imm0 arg_z)
453  (ldr arg_z (:@ imm0 (:$ 0)))
454  (bx lr))
455
456
457(defarmlapfunction %revive-macptr ((p arg_z))
458  (mov imm0 (:$ arm::subtag-macptr))
459  (strb imm0 (:@ p (:$ arm::misc-subtag-offset)))
460  (bx lr))
461
462(defarmlapfunction %macptr-type ((p arg_z))
463  (check-nargs 1)
464  (trap-unless-xtype= p arm::subtag-macptr)
465  (svref imm0 arm::macptr.type-cell p)
466  (box-fixnum arg_z imm0)
467  (bx lr))
468 
469(defarmlapfunction %macptr-domain ((p arg_z))
470  (check-nargs 1)
471  (trap-unless-xtype= p arm::subtag-macptr)
472  (svref imm0 arm::macptr.domain-cell p)
473  (box-fixnum arg_z imm0)
474  (bx lr))
475
476(defarmlapfunction %set-macptr-type ((p arg_y) (new arg_z))
477  (check-nargs 2)
478  (unbox-fixnum imm1 new)
479  (trap-unless-xtype= p arm::subtag-macptr)
480  (svset imm1 arm::macptr.type-cell p)
481  (bx lr))
482
483(defarmlapfunction %set-macptr-domain ((p arg_y) (new arg_z))
484  (check-nargs 2)
485  (unbox-fixnum imm1 new)
486  (trap-unless-xtype= p arm::subtag-macptr)
487  (svset imm1 arm::macptr.domain-cell p)
488  (bx lr))
489
490(defarmlapfunction true ()
491  (:arglist (&rest ignore))
492  (cmp nargs '3)
493  (mov arg_z (:$ arm::nil-value))
494  (add arg_z arg_z (:$ arm::t-offset))
495  (bxls lr)
496  (sub imm0 nargs '3)
497  (add vsp vsp imm0)
498  (bx lr))
499
500(defarmlapfunction false ()
501  (:arglist (&rest ignore))
502  (cmp nargs '3)
503  (mov arg_z (:$ arm::nil-value))
504  (bxls lr)
505  (sub imm0 nargs '3)
506  (add vsp vsp imm0)
507  (bx lr))
508
509
510
511;;; end
Note: See TracBrowser for help on using the repository browser.