source: trunk/source/level-0/ARM/arm-utils.lisp @ 15601

Last change on this file since 15601 was 15488, checked in by gb, 7 years ago

CONSTANT-REF prototype for ARM.

File size: 15.4 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  (spjump .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    (sploadlr .SPfuncall)
115    (blx lr)
116    (ldmia (:! vsp) (fun obj limit))
117    (add obj obj (:$ arm::cons.size))
118    (b @test)
119    @misc
120    (add arg_z obj (:$ arm::fulltag-misc))
121    (stmdb (:! vsp) (fun obj limit))
122    (set-nargs 1)
123    (mov nfn fun)
124    (sploadlr .SPfuncall)
125    (blx lr)
126    (ldmia (:! vsp) (fun obj limit))
127    (ldr header (:@ obj (:$ 0)))
128    (extract-fulltag tag header)
129    (cmp tag (:$ arm::fulltag-nodeheader))
130    (extract-lowbyte subtag header)
131    (bic header header (:$ arm::subtag-mask))
132    (mov header (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift))))
133    (beq @bump)
134    (cmp subtag (:$ arm::max-32-bit-ivector-subtag))
135    (bls @bump)
136    (cmp subtag (:$ arm::max-8-bit-ivector-subtag))
137    (movls header (:lsr header (:$ 2)))
138    (bls @bump)
139    (cmp subtag (:$ arm::max-16-bit-ivector-subtag))
140    (movls header (:lsr header (:$ 1)))
141    (bls @bump)
142    (cmp subtag (:$ arm::subtag-double-float-vector))
143    (movls header (:lsl header (:$ 1)))
144    (bls @bump)
145    (mov header (:lsr header (:$ 2)))
146    (add header header (:$ 7))
147    (mov header (:lsr header (:$ 3)))
148    @bump
149    (add header header (:$ (+ 4 7)))
150    (bic header header (:$ arm::fulltagmask))
151    (add obj obj header)
152    @test
153    (cmp obj limit)
154    (blo @loop)
155    (return-lisp-frame)))
156
157
158
159;;; This walks the active "dynamic" area.  Objects might be moving around
160;;; while we're doing this, so we have to be a lot more careful than we
161;;; are when walking a static area.
162;;; There's the vague notion that we can't take an interrupt when
163;;; "initptr" doesn't equal "freeptr", though what kind of hooks into a
164;;; preemptive scheduler we'd need to enforce this is unclear.  We use
165;;; initptr as an untagged pointer here (and set it to freeptr when we've
166;;; got a tagged pointer to the current object.)
167;;; There are a couple of approaches to termination:
168;;;  a) Allocate a "sentinel" cons, and terminate when we run into it.
169;;;  b) Check the area limit (which is changing if we're consing) and
170;;;     terminate when we hit it.
171;;; (b) loses if the function conses.  (a) conses.  I can't think of anything
172;;; better than (a).
173;;; This, of course, assumes that any GC we're doing does in-place compaction
174;;; (or at least preserves the relative order of objects in the heap.)
175
176(defarmlapfunction %walk-dynamic-area ((a arg_y) (f arg_z))
177  (let ((fun temp1)
178        (obj temp0)
179        (sentinel temp2)
180        (header imm0)
181        (tag imm1)
182        (subtag imm2))
183    (ref-global imm1 tenured-area)   
184    (build-lisp-frame)
185    (mov allocptr (:$ -8))
186    (str allocptr (:@ rcontext (:$ arm::tcr.save-allocbase)))
187    (cmp imm1 (:$ 0))
188    (mov fun f)
189    (movne a imm1)
190    (sub allocptr allocptr (:$ (- arm::cons.size arm::fulltag-cons)))
191    (ldr imm1 (:@ rcontext (:$ arm::tcr.save-allocbase)))
192    (cmp allocptr imm1)
193    (bhi @no-trap)
194    (uuo-alloc-trap)
195    @no-trap
196    (mov sentinel allocptr)
197    (bic allocptr allocptr (:$ arm::fulltagmask))
198    (ldr obj (:@ a (:$ arm::area.low)))
199    (b @test)
200    @loop
201    (test-fixnum obj)
202    (beq @no-debug-trap)
203    (uuo-debug-trap)
204    @no-debug-trap
205    (ldr header (:@ obj (:$ 0)))
206    (extract-fulltag tag header)
207    (cmp tag (:$ arm::fulltag-immheader))   
208    (cmpne tag (:$ arm::fulltag-nodeheader))
209    (beq @misc)
210    (add arg_z obj (:$ arm::fulltag-cons))
211    (cmp arg_z sentinel)
212    (bhs @done)
213    (set-nargs 1)
214    (stmdb (:! vsp) (arg_z fun sentinel))
215    (mov nfn fun)
216    (sploadlr .SPfuncall)
217    (blx lr)
218    (ldmia (:! vsp) (obj fun sentinel))
219    (add obj obj (:$ (- arm::cons.size arm::fulltag-cons)))
220    (b @test)
221    @misc
222    (add arg_z obj (:$ arm::fulltag-misc))
223    (stmdb (:! vsp) (arg_z fun sentinel))
224    (set-nargs 1)
225    (mov nfn fun)
226    (sploadlr .SPfuncall)
227    (blx lr)
228    (ldmia (:! vsp) (obj fun sentinel))
229    (sub obj obj (:$ arm::fulltag-misc))
230    (ldr header (:@ obj (:$ 0)))
231    (extract-fulltag tag header)
232    (cmp tag (:$ arm::fulltag-nodeheader))
233    (extract-lowbyte subtag header)
234    (bic header header (:$ arm::subtag-mask))
235    (mov header (:lsr header (:$ (- arm::num-subtag-bits arm::word-shift))))
236    (beq @bump)
237    (cmp subtag (:$ arm::max-32-bit-ivector-subtag))
238    (bls @bump)
239    (cmp subtag (:$ arm::max-8-bit-ivector-subtag))
240    (movls header (:lsr header (:$ 2)))
241    (bls @bump)
242    (cmp subtag (:$ arm::max-16-bit-ivector-subtag))
243    (movls header (:lsr header (:$ 1)))
244    (bls @bump)
245    (cmp subtag (:$ arm::subtag-double-float-vector))
246    (movls header (:lsl header (:$ 1)))
247    (bls @bump)
248    (mov header (:lsr header (:$ 2)))
249    (add header header (:$ 7))
250    (mov header (:lsr header (:$ 3)))
251    @bump
252    (mov imm2 obj)
253    (add header header (:$ (+ 4 7)))
254    (bic header header (:$ arm::fulltagmask))
255    (add obj obj header)
256    @test
257    (cmp obj sentinel)
258    (blo @loop)
259    (uuo-debug-trap)
260    @done
261    (return-lisp-frame)))
262
263
264
265(defun walk-dynamic-area (area func)
266  (with-other-threads-suspended
267      (%walk-dynamic-area area func)))
268
269
270
271(defarmlapfunction %class-of-instance ((i arg_z))
272  (svref arg_z instance.class-wrapper i)
273  (svref arg_z %wrapper-class arg_z)
274  (bx lr))
275
276(defarmlapfunction class-of ((x arg_z))
277  (check-nargs 1)
278  (extract-fulltag imm0 x)
279  (cmp imm0 (:$ arm::fulltag-misc))
280  (beq @misc)
281  (extract-lowbyte imm0 x)
282  (b @done)
283  @misc
284  (extract-subtag imm0 x)
285  @done
286  (mov imm0 (:lsl imm0 (:$ arm::word-shift)))
287  (ldr temp1 (:@ nfn  '*class-table*))
288  (add imm0 imm0 (:$ arm::misc-data-offset))
289  (ldr temp1 (:@ temp1 (:$ arm::symbol.vcell)))
290  (ldr temp0 (:@ temp1 imm0)) ; get entry from table
291  (cmp temp0 'nil)
292  (beq @bad)
293  ;; functionp?
294  (extract-typecode imm1 temp0)
295  (cmp imm1 (:$ arm::subtag-function))
296  (bne @ret)  ; not function - return entry
297  ;; else jump to the fn
298  (set-nargs 1)
299  (mov nfn temp0)
300  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
301  @bad
302  (set-nargs 1)
303  (ldr fname (:@ nfn 'no-class-error))
304  (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
305  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
306  @ret
307  (mov arg_z temp0)  ; return frob from table
308  (bx lr))
309
310(defarmlapfunction full-gccount ()
311  (ref-global arg_z tenured-area)
312  (cmp arg_z (:$ 0))
313  (bne @from-area)
314  (ref-global arg_z gc-count)
315  (bx lr)
316  @from-area
317  (ldr arg_z (:@ arg_z (:$ arm::area.gc-count)))
318  (bx lr))
319
320
321(defarmlapfunction gc ()
322  (check-nargs 0)
323  (mov imm0 (:$ arch::gc-trap-function-gc))
324  (uuo-gc-trap)
325  (mov arg_z 'nil)
326  (bx lr))
327
328
329;;; Make a list.  This can be faster than doing so by doing CONS
330;;; repeatedly, since the latter strategy might triger the GC several
331;;; times if N is large.
332(defarmlapfunction %allocate-list ((initial-element arg_y) (nconses arg_z))
333  (check-nargs 2)
334  (build-lisp-frame)
335  (mov fn nfn)
336  (uuo-kernel-service (:$ arch::error-allocate-list))
337  (vpush1 arg_z)
338  (vpush1 arg_y)
339  (set-nargs 2)
340  (spjump .SPnvalret))
341
342
343
344(defarmlapfunction egc ((arg arg_z))
345  "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return
346the previous enabled status. Although this function is thread-safe (in
347the sense that calls to it are serialized), it doesn't make a whole lot
348of sense to be turning the EGC on and off from multiple threads ..."
349  (check-nargs 1)
350  (sub imm1 arg 'nil)
351  (mov imm0 (:$ arch::gc-trap-function-egc-control))
352  (uuo-gc-trap)
353  (bx lr))
354
355
356
357(defarmlapfunction %configure-egc ((e0size arg_x)
358                                   (e1size arg_y)
359                                   (e2size arg_z))
360  (check-nargs 3)
361  (mov imm0 (:$ arch::gc-trap-function-configure-egc))
362  (uuo-gc-trap)
363  (bx lr))
364
365(defarmlapfunction purify ()
366  (mov imm0 (:$ arch::gc-trap-function-purify))
367  (uuo-gc-trap)
368  (mov arg_z 'nil)
369  (bx lr))
370
371
372(defarmlapfunction impurify ()
373  (mov imm0 (:$ arch::gc-trap-function-impurify))
374  (uuo-gc-trap)
375  (mov arg_z 'nil)
376  (bx lr))
377
378(defarmlapfunction lisp-heap-gc-threshold ()
379  "Return the value of the kernel variable that specifies the amount
380of free space to leave in the heap after full GC."
381  (check-nargs 0)
382  (mov imm0 (:$ arch::gc-trap-function-get-lisp-heap-threshold))
383  (uuo-gc-trap)
384  (spjump .SPmakeu32))
385
386(defarmlapfunction set-lisp-heap-gc-threshold ((new arg_z))
387  "Set the value of the kernel variable that specifies the amount of free
388space to leave in the heap after full GC to new-value, which should be a
389non-negative fixnum. Returns the value of that kernel variable (which may
390be somewhat larger than what was specified)." 
391  (check-nargs 1)
392  (build-lisp-frame)
393  (sploadlr .SPgetu32)
394  (blx lr)
395  (mov imm1 imm0)
396  (mov imm0 (:$ arch::gc-trap-function-set-lisp-heap-threshold))
397  (uuo-gc-trap)
398  (restore-lisp-frame imm1)
399  (spjump .SPmakeu32))
400
401
402(defarmlapfunction use-lisp-heap-gc-threshold ()
403  "Try to grow or shrink lisp's heap space, so that the free space is(approximately) equal to the current heap threshold. Return NIL"
404  (check-nargs 0) 
405  (mov imm0 (:$ arch::gc-trap-function-use-lisp-heap-threshold))
406  (uuo-gc-trap)
407  (mov arg_z 'nil)
408  (bx lr))
409
410
411(defarmlapfunction freeze ()
412  "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable."
413  (check-nargs 0)
414  (mov imm0 (:$ arch::gc-trap-function-freeze))
415  (uuo-gc-trap)
416  (spjump .SPmakeu32))
417
418(defarmlapfunction flash-freeze ()
419  "Like FREEZE, but don't GC first."
420  (check-nargs 0)
421  (mov imm0 (:$ arch::gc-trap-function-flash-freeze))
422  (uuo-gc-trap)
423  (spjump .SPmakeu32))
424
425(defarmlapfunction allow-heap-allocation ((arg arg_z))
426  "If ARG is true, signal an ALLOCATION-DISABLED condition on attempts
427at heap allocation."
428  (:arglist (arg))
429  (check-nargs 1)
430  (cmp arg_z (:$ arm::nil-value))
431  (mov imm0 (:$ arch::gc-trap-function-allocation-control))
432  (mov imm1 (:$ 0))                     ;disallow
433  (movne imm1 (:$ 1))                   ;allow if arg non-null
434  (uuo-gc-trap)
435  (bx lr))
436
437
438
439(defarmlapfunction heap-allocation-allowed-p ()
440  "Return T if heap allocation is allowed, NIL otherwise."
441  (check-nargs 0)
442  (mov imm0 (:$ arch::gc-trap-function-allocation-control))
443  (mov imm1 (:$ 2))                     ;query
444  (uuo-gc-trap)
445  (bx lr))
446
447(defun %watch (uvector)
448  (declare (ignore uvector))
449  (error "watching objects not supported on ARM yet"))
450
451(defun %unwatch (watched new)
452  (declare (ignore watched new))
453  (error "watching objects not supported on ARM yet"))
454
455
456 
457(defarmlapfunction %ensure-static-conses ()
458  (check-nargs 0)
459  (mov imm0 (:$ arch::gc-trap-function-ensure-static-conses))
460  (uuo-gc-trap)
461  (mov arg_z 'nil)
462  (bx lr))
463
464
465;;; offset is a fixnum, one of the arm::kernel-import-xxx constants.
466;;; Returns that kernel import, a fixnum.
467(defarmlapfunction %kernel-import ((offset arg_z))
468  (ref-global imm0 kernel-imports)
469  (ldr imm0 (:@ imm0 (:asr arg_z (:$ arm::fixnumshift))))
470  (box-fixnum arg_z imm0)
471  (bx lr))
472
473(defarmlapfunction %get-unboxed-ptr ((macptr arg_z))
474  (macptr-ptr imm0 arg_z)
475  (ldr arg_z (:@ imm0 (:$ 0)))
476  (bx lr))
477
478
479(defarmlapfunction %revive-macptr ((p arg_z))
480  (mov imm0 (:$ arm::subtag-macptr))
481  (strb imm0 (:@ p (:$ arm::misc-subtag-offset)))
482  (bx lr))
483
484(defarmlapfunction %macptr-type ((p arg_z))
485  (check-nargs 1)
486  (trap-unless-xtype= p arm::subtag-macptr)
487  (svref imm0 arm::macptr.type-cell p)
488  (box-fixnum arg_z imm0)
489  (bx lr))
490 
491(defarmlapfunction %macptr-domain ((p arg_z))
492  (check-nargs 1)
493  (trap-unless-xtype= p arm::subtag-macptr)
494  (svref imm0 arm::macptr.domain-cell p)
495  (box-fixnum arg_z imm0)
496  (bx lr))
497
498(defarmlapfunction %set-macptr-type ((p arg_y) (new arg_z))
499  (check-nargs 2)
500  (unbox-fixnum imm1 new)
501  (trap-unless-xtype= p arm::subtag-macptr)
502  (svset imm1 arm::macptr.type-cell p)
503  (bx lr))
504
505(defarmlapfunction %set-macptr-domain ((p arg_y) (new arg_z))
506  (check-nargs 2)
507  (unbox-fixnum imm1 new)
508  (trap-unless-xtype= p arm::subtag-macptr)
509  (svset imm1 arm::macptr.domain-cell p)
510  (bx lr))
511
512(defarmlapfunction true ()
513  (:arglist (&rest ignore))
514  (cmp nargs '3)
515  (mov arg_z (:$ arm::nil-value))
516  (add arg_z arg_z (:$ arm::t-offset))
517  (bxls lr)
518  (sub imm0 nargs '3)
519  (add vsp vsp imm0)
520  (bx lr))
521
522(defarmlapfunction false ()
523  (:arglist (&rest ignore))
524  (cmp nargs '3)
525  (mov arg_z (:$ arm::nil-value))
526  (bxls lr)
527  (sub imm0 nargs '3)
528  (add vsp vsp imm0)
529  (bx lr))
530
531(defarmlapfunction constant-ref ()
532  (:arglist (&rest ignore))
533  (cmp nargs '3)
534  (ldr arg_z (:@ nfn 'constant))
535  (bxls lr)
536  (sub imm0 nargs '3)
537  (add vsp vsp imm0)
538  (bx lr))
539
540;;; end
Note: See TracBrowser for help on using the repository browser.