source: branches/arm/level-0/ARM/arm-misc.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: 23.2 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;;; level-0;ARM;arm-misc.lisp
18
19
20(in-package "CCL")
21
22;;; Copy N bytes from pointer src, starting at byte offset src-offset,
23;;; to ivector dest, starting at offset dest-offset.
24;;; It's fine to leave this in lap.
25;;; Depending on alignment, it might make sense to move more than
26;;; a byte at a time.
27;;; Does no arg checking of any kind.  Really.
28
29(defarmlapfunction %copy-ptr-to-ivector ((src (* 1 arm::node-size) )
30                                         (src-byte-offset 0) 
31                                         (dest arg_x)
32                                         (dest-byte-offset arg_y)
33                                         (nbytes arg_z))
34  (let ((src-reg imm0)
35        (src-byteptr temp2)
36        (src-node-reg temp0)
37        (dest-byteptr imm2)
38        (val imm1)
39        (node-temp temp1))
40    (cmp nbytes (:$ 0))
41    (ldr src-node-reg (:@ vsp (:$ src)))
42    (macptr-ptr src-reg src-node-reg)
43    (ldr src-byteptr (:@ vsp (:$ src-byte-offset)))
44    (add src-reg src-reg (:asr src-byteptr (:$ arm::fixnumshift)))
45    (unbox-fixnum dest-byteptr dest-byte-offset)
46    (add dest-byteptr dest-byteptr (:$ arm::misc-data-offset))
47    (b @test)
48    @loop
49    (subs nbytes nbytes '1)
50    (ldrb val (:@+ src-reg (:$ 1)))
51    (strb val (:@ dest dest-byteptr))
52    (add dest-byteptr dest-byteptr (:$ 1))
53    @test
54    (bne  @loop)
55    (mov arg_z dest)
56    (add vsp vsp '2)
57    (bx lr)))
58
59(defarmlapfunction %copy-ivector-to-ptr ((src (* 1 arm::node-size))
60                                         (src-byte-offset 0)
61                                         (dest arg_x)
62                                         (dest-byte-offset arg_y)
63                                         (nbytes arg_z))
64  (ldr temp0 (:@ vsp (:$ src)))
65  (cmp nbytes (:$ 0))
66  (ldr imm0 (:@ vsp (:$ src-byte-offset)))
67  (unbox-fixnum imm0 imm0)
68  (add imm0 imm0 (:$ arm::misc-data-offset))
69  (macptr-ptr imm1 dest)
70  (add imm1 imm1 (:asr dest-byte-offset (:$ arm::fixnumshift)))
71  (b @test)
72  @loop
73  (subs nbytes nbytes '1)
74  (ldrb imm2 (:@ temp0 imm0))
75  (add imm0 imm0 (:$ 1))
76  (strb imm2 (:@+ imm1 (:$ 1)))
77  @test
78  (bne @loop)
79  (mov arg_z dest)
80  (add vsp vsp '2)
81  (bx lr))
82
83#+notyet
84(defarmlapfunction %copy-ivector-to-ivector ((src 4) 
85                                             (src-byte-offset 0) 
86                                             (dest arg_x)
87                                             (dest-byte-offset arg_y)
88                                             (nbytes arg_z))
89  (ldr temp0 (:@ vsp (:$ src)))
90  (cmp nbytes (:$ 0))
91  (cmpw cr2 temp0 dest)   ; source and dest same?
92  (rlwinm imm3 nbytes 0 (- 30 arm::fixnum-shift) 31) 
93  (lwz imm0 src-byte-offset vsp)
94  (rlwinm imm1 imm0 0 (- 30 arm::fixnum-shift) 31)
95  (or imm3 imm3 imm1)
96  (unbox-fixnum imm0 imm0)
97  (la imm0 arm::misc-data-offset imm0)
98  (unbox-fixnum imm2 dest-byte-offset)
99  (rlwimi imm1 imm2 0 30 31)
100  (or imm3 imm3 imm1)
101  (cmpwi cr1 imm3 0)  ; is everybody multiple of 4?
102  (la imm2 arm::misc-data-offset imm2)
103  (beq cr2 @SisD)   ; source and dest same
104  @fwd
105  (beq :cr1 @wtest)
106  (b @test)
107
108  @loop
109  (subi nbytes nbytes '1)
110  (cmpwi cr0 nbytes 0)
111  (lbzx imm3 temp0 imm0)
112  (addi imm0 imm0 1)
113  (stbx imm3 dest imm2)
114  (addi imm2 imm2 1)
115  @test
116  (bne cr0 @loop)
117  (mr arg_z dest)
118  (la vsp 8 vsp)
119  (bx lr)
120
121  @words      ; source and dest different - words
122  (subi nbytes nbytes '4) 
123  (cmpwi cr0 nbytes 0)
124  (lwzx imm3 temp0 imm0)
125  (addi imm0 imm0 4)
126  (stwx imm3 dest imm2)
127  (addi imm2 imm2 4)
128  @wtest
129  (bgt cr0 @words)
130  @done
131  (mr arg_z dest)
132  (la vsp 8 vsp)
133  (bx lr)
134
135  @SisD
136  (cmpw cr2 imm0 imm2) ; cmp src and dest
137  (bgt cr2 @fwd)
138  ;(B @bwd)
139 
140
141  ; Copy backwards when src & dest are the same and we're sliding down
142  @bwd ; ok
143  (unbox-fixnum imm3 nbytes)
144  (add imm0 imm0 imm3)
145  (add imm2 imm2 imm3)
146  (b @test2)
147  @loop2
148  (subi nbytes nbytes '1)
149  (cmpwi cr0 nbytes 0)
150  (subi imm0 imm0 1)
151  (lbzx imm3 temp0 imm0)
152  (subi imm2 imm2 1)
153  (stbx imm3 dest imm2)
154  @test2
155  (bne cr0 @loop2)
156  (b @done))
157
158
159 
160#+notyet
161(defarmlapfunction %copy-gvector-to-gvector ((src (* 1 arm::node-size))
162                                             (src-element 0)
163                                             (dest arg_x)
164                                             (dest-element arg_y)
165                                             (nelements arg_z))
166  (subi nelements nelements '1)
167  (cmpri nelements 0)
168  (ldr imm0 src-element vsp)
169  (ldr temp0 src vsp)
170  (la vsp '2 vsp)
171  (cmpr cr1 temp0 dest)
172  (cmpri cr2 src-element dest-element)
173  (la imm0 arm::misc-data-offset imm0)
174  (la imm1 arm::misc-data-offset dest-element)
175  (bne cr1 @test)
176  ;; Maybe overlap, or maybe nothing to do.
177  (beq cr2 @done)                       ; same vectors, same offsets
178  (blt cr2 @back)                       ; copy backwards, avoid overlap
179  (b @test)
180  @loop
181  (subi nelements nelements '1)
182  (cmpri nelements 0)
183  (ldrx temp1 temp0 imm0)
184  (addi imm0 imm0 '1)
185  (strx temp1 dest imm1)
186  (addi imm1 imm1 '1)
187  @test
188  (bge @loop)
189  @done
190  (mr arg_z dest)
191  (bx lr)
192  @back
193  ;; We decremented NELEMENTS by 1 above.
194  (add imm1 nelements imm1)
195  (add imm0 nelements imm0)
196  (b @back-test)
197  @back-loop
198  (subi nelements nelements '1)
199  (cmpri nelements 0)
200  (ldrx temp1 temp0 imm0)
201  (subi imm0 imm0 '1)
202  (strx temp1 dest imm1)
203  (subi imm1 imm1 '1)
204  @back-test
205  (bge @back-loop)
206  (mr arg_z dest)
207  (bx lr))
208 
209 
210
211(defarmlapfunction %heap-bytes-allocated ()
212  (ldr imm2 (:@ rcontext (:$ arm::tcr.last-allocptr)))
213  (ldr imm1 (:@ rcontext (:$ arm::tcr.total-bytes-allocated-high)))
214  (ldr imm0 (:@ rcontext (:$ arm::tcr.total-bytes-allocated-low)))
215  (cmp imm2 (:$ 0))
216  (sub imm2 imm2 allocptr)
217  (beq @go)
218  (cmp allocptr (:$ -8))
219  (beq @go)
220  (adds imm1 imm1 imm2)
221  (adc imm0 imm0 (:$ 0))
222  @go
223  (b .SPmakeu64))
224
225
226
227
228(defarmlapfunction values ()
229  (:arglist (&rest values))
230  (vpush-argregs)
231  (add temp0 nargs vsp)
232  (ba .SPvalues))
233
234;; It would be nice if (%setf-macptr macptr (ash (the fixnum value)
235;; ash::fixnumshift)) would do this inline.
236(defarmlapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z))
237  (check-nargs 2)
238  (trap-unless-xtype= arg_y arm::subtag-macptr)
239  (str arg_z (:@ arg_y (:$ arm::macptr.address)))
240  (bx lr))
241
242(defarmlapfunction %fixnum-from-macptr ((macptr arg_z))
243  (check-nargs 1)
244  (trap-unless-xtype= arg_z arm::subtag-macptr)
245  (ldr imm0 (:@ arg_z (:$ arm::macptr.address)))
246  (trap-unless-fixnum imm0)
247  (mov arg_z imm0)
248  (bx lr))
249
250(defarmlapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z))
251  (trap-unless-xtype= ptr arm::subtag-macptr)
252  (macptr-ptr imm1 ptr)
253  (unbox-fixnum imm2 offset)
254  (add imm2 imm2 imm1)
255  (ldr imm0 (:@ imm2 (:$ 0)))
256  (ldr imm1 (:@ imm2 (:$ 4)))
257  (ba .SPmakeu64))
258
259
260
261(defarmlapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z))
262  (trap-unless-xtype= ptr arm::subtag-macptr)
263  (macptr-ptr imm1 ptr)
264  (unbox-fixnum imm2 offset)
265  (add imm2 imm2 imm1)
266  (ldr imm0 (:@ imm2 (:$ 0)))           ;low
267  (ldr imm1 (:@ imm2 (:$ 1)))           ;high
268  (ba .SPmakes64))
269
270
271
272(defarmlapfunction %%set-unsigned-longlong ((ptr arg_x)
273                                            (offset arg_y)
274                                            (val arg_z))
275  (build-lisp-frame imm0)
276  (mov fn nfn)
277  (trap-unless-xtype= ptr arm::subtag-macptr) 
278  (bl .SPgetu64)
279  (macptr-ptr imm2 ptr)
280  (add imm2 imm2 (:asr offset (:$ arm::fixnumshift)))
281  (str imm0 (:@ imm2 (:$ 0)))
282  (str imm1 (:@ imm2 (:$ 4)))
283  (return-lisp-frame imm0))
284
285
286
287(defarmlapfunction %%set-signed-longlong ((ptr arg_x)
288                                          (offset arg_y)
289                                          (val arg_z))
290  (build-lisp-frame imm0)
291  (mov fn nfn)
292  (trap-unless-xtype= ptr arm::subtag-macptr)
293  (bl .SPgets64)
294  (macptr-ptr imm2 ptr)
295  (add imm2 imm2 (:asr offset (:$ arm::fixnumshift)))
296  (str imm0 (:@ imm2 (:$ 0)))
297  (str imm1 (:@ imm2 (:$ 4)))
298  (return-lisp-frame imm0))
299
300
301
302(defarmlapfunction interrupt-level ()
303  (ldr arg_z (:@ arm::rcontext (:$ arm::tcr.tlb-pointer)))
304  (ldr arg_z (:@ arg_z (:$ arm::interrupt-level-binding-index)))
305  (bx lr))
306
307
308
309
310(defarmlapfunction set-interrupt-level ((new arg_z))
311  (ldr imm1 (:@ arm::rcontext (:$ arm::tcr.tlb-pointer)))
312  (trap-unless-fixnum new)
313  (str new (:@ imm1 (:$ arm::interrupt-level-binding-index)))
314  (bx lr))
315
316
317
318(defarmlapfunction %current-tcr ()
319  (mov arg_z rcontext)
320  (bx lr))
321
322(defarmlapfunction %tcr-toplevel-function ((tcr arg_z))
323  (check-nargs 1)
324  (cmp tcr arm::rcontext)
325  (mov imm0 vsp)
326  (ldr temp0 (:@ tcr (:$ arm::tcr.vs-area)))
327  (ldr imm1 (:@ temp0 (:$ arm::area.high)))
328  (ldrne imm0 (:@ temp0 (:$ arm::area.active)))
329  (cmp imm1 imm0)
330  (moveq arg_z 'nil)
331  (ldrne arg_z (:@ imm1 (:$ (- arm::node-size))))
332  (bx lr))
333
334(defarmlapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z))
335  (check-nargs 2)
336  (cmp tcr arm::rcontext)
337  (mov imm0 vsp)
338  (ldr temp0 (:@ tcr (:$ arm::tcr.vs-area)))
339  (ldr imm1 (:@ temp0 (:$ arm::area.high)))
340  (ldrne  imm0 (:@ temp0 (:$ arm::area.active)))
341  (cmp imm1 imm0)
342  (mov imm0 ($ 0))
343  (push1 imm0 imm1)
344  (streq imm1 (:@ temp0 (:$ arm::area.active)))
345  (streq imm1 (:@ tcr (:$ arm::tcr.save-vsp)))
346  (str fun (:@ imm1 (:$ 0)))
347  (bx lr))
348
349;;; This needs to be done out-of-line, to handle EGC memoization.
350(defarmlapfunction %store-node-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z))
351  (ba .SPstore-node-conditional))
352
353#+notyet                                ; needs a subprim on ARM
354(defarmlapfunction %store-immediate-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z))
355  (vpop temp0)
356  (unbox-fixnum imm0 temp0)
357  (let ((current temp1))
358    @again
359    (lrarx current object imm0)
360    (cmpr current old)
361    (bne @lose)
362    (strcx. new object imm0)
363    (bne @again)
364    (isync)
365    (li arg_z (+ arm::t-offset (target-nil-value)))
366    (bx lr)
367    @lose
368    (li imm0 arm::reservation-discharge)
369    (strcx. rzero rzero imm0)
370    (li arg_z nil)
371    (bx lr)))
372
373(defarmlapfunction set-%gcable-macptrs% ((ptr arm::arg_z))
374  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
375  (add imm1 imm0 (:$ (arm::kernel-global gcable-pointers)))
376  @again
377  (ldrex arg_y (:@ imm1))
378  (str arg_y (:@ ptr (:$ arm::xmacptr.link)))
379  (strex imm0 ptr (:@ imm1))
380  (cmp imm0 (:$ 0))
381  (bne @again)
382  (bx lr))
383
384;;; Atomically increment or decrement the gc-inhibit-count kernel-global
385;;; (It's decremented if it's currently negative, incremented otherwise.)
386(defarmlapfunction %lock-gc-lock ()
387  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
388  (add imm1 imm0 (:$ (arm::kernel-global gc-inhibit-count)))
389  @again
390  (ldrex arg_y (:@ imm1))
391  (cmp arg_y (:$ 0))
392  (add arg_z arg_y '1)
393  (sublt arg_z arg_y '1)
394  @store
395  (strex imm0 arg_z (:@ imm1))
396  (cmp imm0 (:$ 0))
397  (bne @again)
398  (bx lr))
399
400;;; Atomically decrement or increment the gc-inhibit-count kernel-global
401;;; (It's incremented if it's currently negative, incremented otherwise.)
402;;; If it's incremented from -1 to 0, try to GC (maybe just a little.)
403#+notyet                                ;Needs ARM subprim ?
404(defarmlapfunction %unlock-gc-lock ()
405;;  (sync)
406  (li imm0 (+ (target-nil-value) (arm::kernel-global gc-inhibit-count)))
407  @again
408  (lrarx arg_y rzero imm0)
409  (cmpri cr1 arg_y -1)
410  (subi arg_z arg_y '1)
411  (bgt cr1 @store)
412  (addi arg_z arg_y '1)
413  @store
414  (strcx. arg_z rzero imm0)
415  (bne @again)
416  (bnelr cr1)
417  ;; The GC tried to run while it was inhibited.  Unless something else
418  ;; has just inhibited it, it should be possible to GC now.
419  (li imm0 arch::gc-trap-function-immediate-gc)
420  (trlgei allocptr 0)
421  (bx lr))
422
423
424#+notyet                                ;needs ARM subprim ?
425(defarmlapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
426  (check-nargs 3)
427  (unbox-fixnum imm1 disp)
428  @again
429  (lrarx arg_z node imm1)
430  (add arg_z arg_z by)
431  (strcx. arg_z node imm1)
432  (bne- @again)
433  (isync)
434  (bx lr))
435
436#+notyet                                ;needs ARM subprim ?
437(defarmlapfunction %atomic-incf-ptr ((ptr arg_z))
438  (macptr-ptr imm1 ptr)
439  @again
440  (lrarx imm0 0 imm1)
441  (addi imm0 imm0 1)
442  (strcx. imm0 0 imm1)
443  (bne @again)
444  (isync)
445  (box-fixnum arg_z imm0)
446  (bx lr))
447
448#+notyet                                ;needs ARM subprim ?
449(defarmlapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z))
450  (macptr-ptr imm1 ptr)
451  (unbox-fixnum imm2 by)
452  @again
453  (lrarx imm0 0 imm1)
454  (add imm0 imm0 imm2)
455  (strcx. imm0 0 imm1)
456  (bne @again)
457  (isync)
458  (box-fixnum arg_z imm0)
459  (bx lr))
460
461#+notyet                                ;needs ARM subprim
462(defarmlapfunction %atomic-decf-ptr ((ptr arg_z))
463  (macptr-ptr imm1 ptr)
464  @again
465  (lrarx imm0 0 imm1)
466  (subi imm0 imm0 1)
467  (strcx. imm0 0 imm1)
468  (bne @again)
469  (isync)
470  (box-fixnum arg_z imm0)
471  (bx lr))
472
473#+notyet                                ;Needs ARM subprim ?
474(defarmlapfunction %atomic-decf-ptr-if-positive ((ptr arg_z))
475  (macptr-ptr imm1 ptr)
476  @again
477  (lrarx imm0 0 imm1)
478  (cmpri cr1 imm0 0)
479  (subi imm0 imm0 1)
480  (beq @done)
481  (strcx. imm0 0 imm1)
482  (bne @again)
483  (isync)
484  (box-fixnum arg_z imm0)
485  (bx lr)
486  @done
487  (li imm1 arm::reservation-discharge)
488  (box-fixnum arg_z imm0)
489  (strcx. rzero rzero imm1)
490  (bx lr))
491
492#+notyet                                ;guess why not ?
493(defarmlapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z))
494  (sync)
495  (macptr-ptr imm1 ptr)
496  (unbox-fixnum imm2 arg_z)
497  @again
498  (lrarx imm0 0 imm1)
499  (strcx. imm2 0 imm1)
500  (bne @again)
501  (isync)
502  (box-fixnum arg_z imm0)
503  (bx lr))
504
505;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value
506;;; was equal to OLDVAL.  Return the old value
507#+notyet                                 ;still
508(defarmlapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
509  (macptr-ptr imm0 ptr)
510  (unbox-fixnum imm1 expected-oldval)
511  (unbox-fixnum imm2 newval)
512  @again
513  (lrarx imm3 0 imm0)
514  (cmpr imm3 imm1)
515  (bne- @done)
516  (strcx. imm2 0 imm0)
517  (bne- @again)
518  (isync)
519  (box-fixnum arg_z imm3)
520  (bx lr)
521  @done
522  (li imm0 arm::reservation-discharge)
523  (box-fixnum arg_z imm3)
524  (strcx. rzero 0 imm0)
525  (bx lr))
526
527#+notyet                                ; Yet ?  Not.
528(defarmlapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
529  (let ((address imm0)
530        (actual-oldval imm1))
531    (macptr-ptr address ptr)
532    @again
533    (lrarx actual-oldval 0 address)
534    (cmpr actual-oldval expected-oldval)
535    (bne- @done)
536    (strcx. newval 0 address)
537    (bne- @again)
538    (isync)
539    (mov arg_z actual-oldval)
540    (bx lr)
541    @done
542    (li address arm::reservation-discharge)
543    (mov arg_z actual-oldval)
544    (strcx. rzero 0 address)
545    (bx lr)))
546
547
548
549
550(defarmlapfunction %macptr->dead-macptr ((macptr arg_z))
551  (check-nargs 1)
552  (mov imm0 (:$ arm::subtag-dead-macptr))
553  (strb imm0 (:@ macptr (:$ arm::misc-subtag-offset)))
554  (bx lr))
555
556#+notyet                                ;for different reasons
557(defarmlapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0)
558                                     (parent arg_x) (function arg_y) (arglist arg_z))
559  (check-nargs 7)
560
561  ; Throw through catch-count catch frames
562  (lwz imm0 12 vsp)                      ; catch-count
563  (vpush parent)
564  (vpush function)
565  (vpush arglist)
566  (bla .SPnthrowvalues)
567
568  ; Pop tsp-count TSP frames
569  (lwz tsp-count 16 vsp)
570  (cmpi cr0 tsp-count 0)
571  (b @test)
572@loop
573  (subi tsp-count tsp-count '1)
574  (cmpi cr0 tsp-count 0)
575  (lwz tsp 0 tsp)
576@test
577  (bne cr0 @loop)
578
579  ; Pop dynamic bindings until we get to db-link
580  (lwz imm0 12 vsp)                     ; db-link
581  (lwz imm1 arm::tcr.db-link arm::rcontext)
582  (cmp cr0 imm0 imm1)
583  (beq cr0 @restore-regs)               ; .SPunbind-to expects there to be something to do
584  (bla .SPunbind-to)
585
586@restore-regs
587  ; restore the saved registers from srv
588  (lwz srv 20 vsp)
589@get0
590  (svref imm0 1 srv)
591  (cmpwi cr0 imm0 (target-nil-value))
592  (beq @get1)
593  (lwz save0 0 imm0)
594@get1
595  (svref imm0 2 srv)
596  (cmpwi cr0 imm0 (target-nil-value))
597  (beq @get2)
598  (lwz save1 0 imm0)
599@get2
600  (svref imm0 3 srv)
601  (cmpwi cr0 imm0 (target-nil-value))
602  (beq @get3)
603  (lwz save2 0 imm0)
604@get3
605  (svref imm0 4 srv)
606  (cmpwi cr0 imm0 (target-nil-value))
607  (beq @get4)
608  (lwz save3 0 imm0)
609@get4
610  (svref imm0 5 srv)
611  (cmpwi cr0 imm0 (target-nil-value))
612  (beq @get5)
613  (lwz save4 0 imm0)
614@get5
615  (svref imm0 6 srv)
616  (cmpwi cr0 imm0 (target-nil-value))
617  (beq @get6)
618  (lwz save5 0 imm0)
619@get6
620  (svref imm0 7 srv)
621  (cmpwi cr0 imm0 (target-nil-value))
622  (beq @get7)
623  (lwz save6 0 imm0)
624@get7
625  (svref imm0 8 srv)
626  (cmpwi cr0 imm0 (target-nil-value))
627  (beq @got)
628  (lwz save7 0 imm0)
629@got
630
631  (vpop arg_z)                          ; arglist
632  (vpop temp0)                          ; function
633  (vpop parent)                         ; parent
634  (extract-lisptag imm0 parent)
635  (cmpi cr0 imm0 arm::tag-fixnum)
636  (if (:cr0 :ne)
637    ; Parent is a fake-stack-frame. Make it real
638    (progn
639      (svref sp %fake-stack-frame.sp parent)
640      (stwu sp (- arm::lisp-frame.size) sp)
641      (svref fn %fake-stack-frame.fn parent)
642      (stw fn arm::lisp-frame.savefn sp)
643      (svref temp1 %fake-stack-frame.vsp parent)
644      (stw temp1 arm::lisp-frame.savevsp sp)
645      (svref temp1 %fake-stack-frame.lr parent)
646      (extract-lisptag imm0 temp1)
647      (cmpi cr0 imm0 arm::tag-fixnum)
648      (if (:cr0 :ne)
649        ;; must be a macptr encoding the actual link register
650        (macptr-ptr loc-pc temp1)
651        ;; Fixnum is offset from start of function vector
652        (progn
653          (svref temp2 0 fn)        ; function vector
654          (unbox-fixnum temp1 temp1)
655          (add loc-pc temp2 temp1)))
656      (stw loc-pc arm::lisp-frame.savelr sp))
657    ;; Parent is a real stack frame
658    (mov sp parent))
659  (set-nargs 0)
660  (bla .SPspreadargz)
661  (ba .SPtfuncallgen))
662
663
664
665       
666
667#+notyet
668(defarmlapfunction %%save-application ((flags arg_y) (fd arg_z))
669  (unbox-fixnum imm0 flags)
670  (orr imm0 imm0 arch::gc-trap-function-save-application)
671  (unbox-fixnum imm1 fd)
672  (trlgei allocptr 0)
673  (bx lr))
674
675
676
677(defarmlapfunction %misc-address-fixnum ((misc-object arg_z))
678  (check-nargs 1)
679  (add arg_z misc-object (:$ arm::misc-data-offset))
680  (bx lr))
681
682
683(defarmlapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z))
684  (check-nargs 3)
685  (macptr-ptr imm1 ptr) ; address in macptr
686  (add imm0 imm1 (:$ 9))     ; 2 for delta + 7 for alignment
687  (bic imm0 imm0 (:$ 7))   ; Clear low three bits to align
688  (rsb imm1 imm1 imm0)  ; imm1 = delta
689  (strh imm1 (:@  imm0 (:$ -2)))     ; save delta halfword
690  (unbox-fixnum imm1 subtype)  ; subtype at low end of imm1
691  (orr imm1 imm1 (:lsl len (:$ (- arm::num-subtag-bits arm::fixnum-shift))))
692  (str imm1 (:@ imm0 (:$ 0)))       ; store subtype & length
693  (add arg_z imm0 (:$ arm::fulltag-misc)) ; tag it, return it
694  (bx lr))
695
696
697
698(defarmlapfunction %%make-disposable ((ptr arg_y) (vector arg_z))
699  (check-nargs 2)
700  (sub imm0 vector (:$ arm::fulltag-misc)) ; imm0 is addr = vect less tag
701  (ldrh imm1 (:@ imm0 (:$ -2)))   ; get delta
702  (sub imm0 imm0 imm1)  ; vector addr (less tag)  - delta is orig addr
703  (str imm0 (:@ ptr (:$ arm::macptr.address)))
704  (bx lr))
705
706(defarmlapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z))
707  ;; put address of vect data in macptr.  For all vector types
708  ;; other than DOUBLE-FLOAT (or vectors thereof), the first byte
709  ;; of data is at ARM::MISC-DATA-OFFSET; for the double-float
710  ;; types, it's at ARM::MISC-DFLOAT-OFFSET.
711  (extract-subtag imm0 vect)
712  (cmp imm0 (:$ arm::subtag-double-float-vector))
713  (cmpne imm0 (:$ arm::subtag-double-float))
714  (addne temp0 vect (:$ arm::misc-data-offset))
715  (addeq temp0 vect (:$ arm::misc-dfloat-offset))
716  (str temp0 (:@ arg_z (:$ arm::macptr.address)))
717  (bx lr))
718
719
720(defarmlapfunction %current-db-link ()
721  (ldr arg_z (:@ arm::rcontext (:$ arm::tcr.db-link)))
722  (bx lr))
723
724(defarmlapfunction %no-thread-local-binding-marker ()
725  (mov arg_z (:$ arm::subtag-no-thread-local-binding))
726  (bx lr))
727
728
729
730;;; Should be called with interrupts disabled.
731(defarmlapfunction %safe-get-ptr ((src arg_y) (dest arg_z))
732  (check-nargs 2)
733  (macptr-ptr imm0 src)
734  (str imm0 (:@ arm::rcontext (:$ arm::tcr.safe-ref-address)))
735  (ldr imm0 (:@ imm0 (:$ 0)))                     ; may fault
736  (str imm0 (:@ dest (:$ arm::macptr.address)))
737  (bx lr))
738
739
740
741;;; r13 contains thread context on Linux/Darwin PPC64.
742;;; That's maintained in r2 on LinuxPPC32, and not maintained
743;;; in a GPR on DarwinPPC32
744#+huh
745(defarmlapfunction %get-os-context ()
746  #+ppc64-target (mov arg_z 13)
747  #+linuxppc32-target (mov arg_z 2)
748  #+darinppc32-target (mov arg_z 0)
749  (bx lr))
750
751#+bad-idea
752(defarmlapfunction %check-deferred-gc ()
753  (ldr imm0 arm::tcr.flags arm::rcontext)
754  (slri. imm0 imm0 (- (1- arm::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend arm::fixnumshift)))
755  (li arg_z nil)
756  (bgelr)
757  (uuo_interr arch::error-propagate-suspend rzero)
758  (li arg_z t)
759  (bx lr))
760
761#+later
762(progn
763
764(defarmlapfunction %%tcr-interrupt ((target arg_z))
765  (check-nargs 1)
766  (uuo_interr arch::error-interrupt rzero)
767  (box-fixnum arg_z imm0)
768  (bx lr))
769
770(defarmlapfunction %suspend-tcr ((target arg_z))
771  (check-nargs 1)
772  (uuo_interr arch::error-suspend rzero)
773  (ne0->boolean arg_z imm0 imm1)
774  (bx lr))
775
776(defarmlapfunction %suspend-other-threads ()
777  (check-nargs 0)
778  (uuo_interr arch::error-suspend-all rzero)
779  (li arg_z nil)
780  (bx lr))
781
782(defarmlapfunction %resume-tcr ((target arg_z))
783  (check-nargs 1)
784  (uuo_interr arch::error-resume rzero)
785  (ne0->boolean arg_z imm0 imm1)
786  (bx lr))
787
788(defarmlapfunction %resume-other-threads ()
789  (check-nargs 0)
790  (uuo_interr arch::error-resume-all rzero)
791  (li arg_z nil)
792  (bx lr))
793
794(defarmlapfunction %kill-tcr ((target arg_z))
795  (check-nargs 1)
796  (uuo_interr arch::error-kill rzero)
797  (ne0->boolean arg_z imm0 imm1)
798  (bx lr))
799
800(defarmlapfunction %atomic-pop-static-cons ()
801  (li imm0 (+ (target-nil-value) (arm::kernel-global static-conses)))
802  @again
803  (lrarx arg_z rzero imm0)
804  (cmpri arg_z (target-nil-value))
805  (beq @lose)
806  (%cdr arg_y arg_z)
807  (strcx. arg_y rzero imm0)
808  (bne @again)
809  (li imm0 (+ (target-nil-value) (arm::kernel-global free-static-conses)))
810  @decf
811  (lrarx imm1 rzero imm0)
812  (subi imm1 imm1 '1)
813  (strcx. imm1 rzero imm0)
814  (bne @decf)
815  (isync)
816  (bx lr)
817  @lose
818  (li imm0 arm::reservation-discharge)
819  (strcx. rzero rzero imm0)
820  (bx lr))
821
822
823
824(defarmlapfunction %staticp ((x arg_z))
825  (check-nargs 1)
826  (ref-global temp0 static-cons-area)
827  (ldr imm1 arm::area.low temp0)
828  (sub imm0 x imm1)
829  (ldr imm1 arm::area.ndnodes temp0)
830  (srri imm0 imm0 arm::dnode-shift)
831  (li arg_z nil)
832  (sub imm1 imm1 imm0)
833  (cmplri imm1 0)
834  (la imm1 128 imm1)
835  (blelr)
836  (box-fixnum arg_z imm1)
837  (bx lr))
838
839(defarmlapfunction %static-inverse-cons ((n arg_z))
840  (check-nargs 1)
841  (extract-lisptag imm0 arg_z)
842  (cmpri imm0 0)
843  (ref-global temp0 static-cons-area)
844  (bne @fail)
845  (la n '-128 n)
846  (ldr imm0 arm::area.ndnodes temp0)
847  (ldr imm1 arm::area.high temp0)
848  (box-fixnum arg_y imm0)
849  (sub imm1 imm1 n)
850  (cmplr arg_z arg_y)
851  (sub imm1 imm1 n)
852  (bgt @fail)
853  (la arg_z arm::fulltag-cons imm1)
854  (ldr arg_y arm::cons.car arg_z)
855  (cmpri arg_y arm::unbound-marker)
856  (bnelr)
857  @fail
858  (li arg_z nil)
859  (bx lr))
860); #+later
861
862
863; end of arm-misc.lisp
Note: See TracBrowser for help on using the repository browser.