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

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

Yet another scheme for subprim calls. Go ahead and laugh.
Details:

  • ba/bla are new pseudo instructions, identical to b/bl except that their operands are subprim names (or addresses).
  • for each subprim name/address referenced in a ba/bla instruction, the assembler generates an:

(ldr pc (:= data-word-containing-subprim-address))

instruction and makes the ba/bla branch to that instruction.

  • this is the only use of the "constant pool" and there are no longer user-visible directives for referencing pc-relative data. (We can load 32-bit integer constants via movw/movt instructions and initialize FPRs to constants via GPRs.)
  • by default, the disassembler hides this and shows ba/bla instructions.

Compared to the scheme of a few days ago, it's about the same speed
(b/bl to LDR vs mov reg/bx reg). If a subprim's called once per function
it's a little bigger; if there's more than one call site, it can be smaller.
(And we don't have to find a temp register.) If we can map the subprims
to addresses within 32MB of the pure area, then purify can turn the PC-relative
branches/bls to the LDR instructions into direct branches/bls to the code.

Compared to the original scheme (branch/bl to mov pc, #n) we don't flush
the pipeline on every call and don't have any constraints on subprimitive
addresses (they don't have to be expressible as ARM constants.)

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