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

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

Lots of (mostly small) changes.

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