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