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

Last change on this file since 14104 was 14104, checked in by gb, 11 years ago

Don't use "ba" pseudo-instruction.

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