source: trunk/source/level-0/PPC/ppc-misc.lisp @ 13355

Last change on this file since 13355 was 13355, checked in by gb, 10 years ago

No ppc32::unbound, either.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.9 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;;; level-0;x86;x86-misc.lisp
19
20
21(in-package "CCL")
22
23;;; Copy N bytes from pointer src, starting at byte offset src-offset,
24;;; to ivector dest, starting at offset dest-offset.
25;;; It's fine to leave this in lap.
26;;; Depending on alignment, it might make sense to move more than
27;;; a byte at a time.
28;;; Does no arg checking of any kind.  Really.
29
30(defppclapfunction %copy-ptr-to-ivector ((src (* 1 target::node-size) )
31                                         (src-byte-offset 0) 
32                                         (dest arg_x)
33                                         (dest-byte-offset arg_y)
34                                         (nbytes arg_z))
35  (let ((src-reg imm0)
36        (src-byteptr imm1)
37        (src-node-reg temp0)
38        (dest-byteptr imm2)
39        (val imm3)
40        (node-temp temp1))
41    (cmpri cr0 nbytes 0)
42    (ldr src-node-reg src vsp)
43    (macptr-ptr src-reg src-node-reg)
44    (ldr src-byteptr src-byte-offset vsp)
45    (unbox-fixnum src-byteptr src-byteptr)
46    (unbox-fixnum dest-byteptr dest-byte-offset)
47    (la dest-byteptr target::misc-data-offset dest-byteptr)
48    (b @test)
49    @loop
50    (subi nbytes nbytes '1)
51    (cmpri cr0 nbytes '0)
52    (lbzx val src-reg src-byteptr)
53    (la src-byteptr 1 src-byteptr)
54    (stbx val dest dest-byteptr)
55    (la dest-byteptr 1 dest-byteptr)
56    @test
57    (bne cr0 @loop)
58    (mr arg_z dest)
59    (la vsp '2 vsp)
60    (blr)))
61
62(defppclapfunction %copy-ivector-to-ptr ((src (* 1 target::node-size))
63                                         (src-byte-offset 0) 
64                                         (dest arg_x)
65                                         (dest-byte-offset arg_y)
66                                         (nbytes arg_z))
67  (ldr temp0 src vsp)
68  (cmpri cr0 nbytes 0)
69  (ldr imm0 src-byte-offset vsp)
70  (unbox-fixnum imm0 imm0)
71  (la imm0 target::misc-data-offset imm0)
72  (unbox-fixnum imm2 dest-byte-offset)
73  (ldr imm1 target::macptr.address dest)
74  (b @test)
75  @loop
76  (subi nbytes nbytes '1)
77  (cmpri cr0 nbytes 0)
78  (lbzx imm3 temp0 imm0)
79  (addi imm0 imm0 1)
80  (stbx imm3 imm1 imm2)
81  (addi imm2 imm2 1)
82  @test
83  (bne cr0 @loop)
84  (mr arg_z dest)
85  (la vsp '2 vsp)
86  (blr))
87
88#+ppc32-target
89(defppclapfunction %copy-ivector-to-ivector ((src 4) 
90                                             (src-byte-offset 0) 
91                                             (dest arg_x)
92                                             (dest-byte-offset arg_y)
93                                             (nbytes arg_z))
94  (lwz temp0 src vsp)
95  (cmpwi cr0 nbytes 0)
96  (cmpw cr2 temp0 dest)   ; source and dest same?
97  (rlwinm imm3 nbytes 0 (- 30 target::fixnum-shift) 31) 
98  (lwz imm0 src-byte-offset vsp)
99  (rlwinm imm1 imm0 0 (- 30 target::fixnum-shift) 31)
100  (or imm3 imm3 imm1)
101  (unbox-fixnum imm0 imm0)
102  (la imm0 target::misc-data-offset imm0)
103  (unbox-fixnum imm2 dest-byte-offset)
104  (rlwimi imm1 imm2 0 30 31)
105  (or imm3 imm3 imm1)
106  (cmpwi cr1 imm3 0)  ; is everybody multiple of 4?
107  (la imm2 target::misc-data-offset imm2)
108  (beq cr2 @SisD)   ; source and dest same
109  @fwd
110  (beq :cr1 @wtest)
111  (b @test)
112
113  @loop
114  (subi nbytes nbytes '1)
115  (cmpwi cr0 nbytes 0)
116  (lbzx imm3 temp0 imm0)
117  (addi imm0 imm0 1)
118  (stbx imm3 dest imm2)
119  (addi imm2 imm2 1)
120  @test
121  (bne cr0 @loop)
122  (mr arg_z dest)
123  (la vsp 8 vsp)
124  (blr)
125
126  @words      ; source and dest different - words
127  (subi nbytes nbytes '4) 
128  (cmpwi cr0 nbytes 0)
129  (lwzx imm3 temp0 imm0)
130  (addi imm0 imm0 4)
131  (stwx imm3 dest imm2)
132  (addi imm2 imm2 4)
133  @wtest
134  (bgt cr0 @words)
135  @done
136  (mr arg_z dest)
137  (la vsp 8 vsp)
138  (blr)
139
140  @SisD
141  (cmpw cr2 imm0 imm2) ; cmp src and dest
142  (bgt cr2 @fwd)
143  ;(B @bwd)
144 
145
146  ; Copy backwards when src & dest are the same and we're sliding down
147  @bwd ; ok
148  (unbox-fixnum imm3 nbytes)
149  (add imm0 imm0 imm3)
150  (add imm2 imm2 imm3)
151  (b @test2)
152  @loop2
153  (subi nbytes nbytes '1)
154  (cmpwi cr0 nbytes 0)
155  (subi imm0 imm0 1)
156  (lbzx imm3 temp0 imm0)
157  (subi imm2 imm2 1)
158  (stbx imm3 dest imm2)
159  @test2
160  (bne cr0 @loop2)
161  (b @done))
162
163#+ppc64-target
164(defppclapfunction %copy-ivector-to-ivector ((src-offset 8) 
165                                             (src-byte-offset-offset 0) 
166                                             (dest arg_x)
167                                             (dest-byte-offset arg_y)
168                                             (nbytes arg_z))
169  (let ((src temp0)
170        (src-byte-offset imm0))
171    (subi nbytes nbytes '1)
172    (ld src-byte-offset src-byte-offset-offset vsp)
173    (cmpdi nbytes 0 )
174    (ld src src-offset vsp)
175    (la vsp '2 vsp)
176    (cmpd cr1 src dest)
177    (cmpdi cr2 src-byte-offset dest-byte-offset)
178    (unbox-fixnum src-byte-offset src-byte-offset)
179    (unbox-fixnum imm1 dest-byte-offset)
180    (la imm0 target::misc-data-offset src-byte-offset)
181    (la imm1 target::misc-data-offset imm1)
182    (bne cr1 @test)
183    ;; Maybe overlap, or maybe nothing to do.
184    (beq cr2 @done)                       ; same vectors, same offsets
185    (blt cr2 @back)                       ; copy backwards, avoid overlap
186    (b @test)
187    @loop
188    (subi nbytes nbytes '1)
189    (lbzx imm3 src imm0)
190    (cmpdi nbytes 0)
191    (addi imm0 imm0 1)
192    (stbx imm3 dest imm1)
193    (addi imm1 imm1 1)
194    @test
195    (bge @loop)
196    @done
197    (mr arg_z dest)
198    (blr)
199    @back
200    ;; nbytes was predecremented above
201    (unbox-fixnum imm2 nbytes)
202    (add imm0 imm2 imm0)
203    (add imm1 imm2 imm1)
204    (b @back-test)
205    @back-loop
206    (subi nbytes nbytes '1)
207    (lbzx imm3 src imm0)
208    (cmpdi nbytes 0)
209    (subi imm0 imm0 1)
210    (stbx imm3 dest imm1)
211    (subi imm1 imm1 1)
212    @back-test
213    (bge @back-loop)
214    (mr arg_z dest)
215    (blr)))
216 
217
218(defppclapfunction %copy-gvector-to-gvector ((src (* 1 target::node-size))
219                                             (src-element 0)
220                                             (dest arg_x)
221                                             (dest-element arg_y)
222                                             (nelements arg_z))
223  (subi nelements nelements '1)
224  (cmpri nelements 0)
225  (ldr imm0 src-element vsp)
226  (ldr temp0 src vsp)
227  (la vsp '2 vsp)
228  (cmpr cr1 temp0 dest)
229  (cmpri cr2 src-element dest-element)
230  (la imm0 target::misc-data-offset imm0)
231  (la imm1 target::misc-data-offset dest-element)
232  (bne cr1 @test)
233  ;; Maybe overlap, or maybe nothing to do.
234  (beq cr2 @done)                       ; same vectors, same offsets
235  (blt cr2 @back)                       ; copy backwards, avoid overlap
236  (b @test)
237  @loop
238  (subi nelements nelements '1)
239  (cmpri nelements 0)
240  (ldrx temp1 temp0 imm0)
241  (addi imm0 imm0 '1)
242  (strx temp1 dest imm1)
243  (addi imm1 imm1 '1)
244  @test
245  (bge @loop)
246  @done
247  (mr arg_z dest)
248  (blr)
249  @back
250  ;; We decremented NELEMENTS by 1 above.
251  (add imm1 nelements imm1)
252  (add imm0 nelements imm0)
253  (b @back-test)
254  @back-loop
255  (subi nelements nelements '1)
256  (cmpri nelements 0)
257  (ldrx temp1 temp0 imm0)
258  (subi imm0 imm0 '1)
259  (strx temp1 dest imm1)
260  (subi imm1 imm1 '1)
261  @back-test
262  (bge @back-loop)
263  (mr arg_z dest)
264  (blr))
265 
266 
267
268
269
270#+ppc32-target
271(defppclapfunction %heap-bytes-allocated ()
272  (lwz imm2 target::tcr.last-allocptr ppc32::rcontext)
273  (cmpwi cr1 imm2 0)
274  (cmpwi allocptr -8)                   ;void_allocptr
275  (lwz imm0 target::tcr.total-bytes-allocated-high ppc32::rcontext)
276  (lwz imm1 target::tcr.total-bytes-allocated-low ppc32::rcontext)
277  (sub imm2 imm2 allocptr)
278  (beq cr1 @go)
279  (beq @go)
280  (addc imm1 imm1 imm2)
281  (addze imm0 imm0)
282  @go
283  (ba .SPmakeu64))
284
285#+ppc64-target
286(defppclapfunction %heap-bytes-allocated ()
287  (ld imm2 target::tcr.last-allocptr ppc64::rcontext)
288  (cmpri cr1 imm2 0)
289  (cmpri allocptr -16)                  ;void_allocptr
290  (ld imm0 target::tcr.total-bytes-allocated-high ppc64::rcontext)
291  (sub imm2 imm2 allocptr)
292  (beq cr1 @go)
293  (beq @go)
294  (add imm0 imm0 imm2)
295  @go
296  (ba .SPmakeu64))
297
298
299(defppclapfunction values ()
300  (:arglist (&rest values))
301  (vpush-argregs)
302  (add temp0 nargs vsp)
303  (ba .SPvalues))
304
305;; It would be nice if (%setf-macptr macptr (ash (the fixnum value) ash::fixnumshift))
306;; would do this inline.
307#+ppc-target
308(defppclapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z))
309  (check-nargs 2)
310  (trap-unless-typecode= arg_y target::subtag-macptr)
311  (str arg_z target::macptr.address arg_y)
312  (blr))
313
314(defppclapfunction %fixnum-from-macptr ((macptr arg_z))
315  (check-nargs 1)
316  (trap-unless-typecode= arg_z target::subtag-macptr)
317  (ldr imm0 target::macptr.address arg_z)
318  (trap-unless-lisptag= imm0 target::tag-fixnum imm1)
319  (mr arg_z imm0)
320  (blr))
321
322#+ppc32-target
323(defppclapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z))
324  (trap-unless-typecode= ptr ppc32::subtag-macptr)
325  (macptr-ptr imm1 ptr)
326  (unbox-fixnum imm2 offset)
327  (add imm2 imm2 imm1)
328  (lwz imm0 0 imm2)
329  (lwz imm1 4 imm2)
330  (ba .SPmakeu64))
331
332#+ppc64-target
333(defppclapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z))
334  (trap-unless-typecode= ptr ppc64::subtag-macptr)
335  (macptr-ptr imm1 ptr)
336  (unbox-fixnum imm2 offset)
337  (ldx imm0 imm2 imm1)
338  (ba .SPmakeu64))
339
340#+ppc32-target
341(defppclapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z))
342  (trap-unless-typecode= ptr ppc32::subtag-macptr)
343  (macptr-ptr imm1 ptr)
344  (unbox-fixnum imm2 offset)
345  (add imm2 imm2 imm1)
346  (lwz imm0 0 imm2)
347  (lwz imm1 4 imm2)
348  (ba .SPmakes64))
349
350#+ppc64-target
351(defppclapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z))
352  (trap-unless-typecode= ptr ppc64::subtag-macptr)
353  (macptr-ptr imm1 ptr)
354  (unbox-fixnum imm2 offset)
355  (ldx imm0 imm2 imm1)
356  (ba .SPmakes64))
357
358#+ppc32-target
359(defppclapfunction %%set-unsigned-longlong ((ptr arg_x)
360                                              (offset arg_y)
361                                              (val arg_z))
362  (save-lisp-context)
363  (trap-unless-typecode= ptr ppc32::subtag-macptr)
364  (bla .SPgetu64)
365  (macptr-ptr imm2 ptr)
366  (unbox-fixnum imm3 offset)
367  (add imm2 imm3 imm2)
368  (stw imm0 0 imm2)
369  (stw imm1 4 imm2)
370  (ba .SPpopj))
371
372#+ppc64-target
373(defppclapfunction %%set-unsigned-longlong ((ptr arg_x)
374                                            (offset arg_y)
375                                            (val arg_z))
376  (save-lisp-context)
377  (trap-unless-typecode= ptr ppc64::subtag-macptr)
378  (bla .SPgetu64)
379  (macptr-ptr imm2 ptr)
380  (unbox-fixnum imm3 offset)
381  (stdx imm0 imm3 imm2)
382  (ba .SPpopj))
383
384#+ppc32-target
385(defppclapfunction %%set-signed-longlong ((ptr arg_x)
386                                            (offset arg_y)
387                                            (val arg_z))
388  (save-lisp-context)
389  (trap-unless-typecode= ptr ppc32::subtag-macptr)
390  (bla .SPgets64)
391  (macptr-ptr imm2 ptr)
392  (unbox-fixnum imm3 offset)
393  (add imm2 imm3 imm2)
394  (stw imm0 0 imm2)
395  (stw imm1 4 imm2)
396  (ba .SPpopj))
397
398#+ppc64-target
399(defppclapfunction %%set-signed-longlong ((ptr arg_x)
400                                          (offset arg_y)
401                                          (val arg_z))
402  (save-lisp-context)
403  (trap-unless-typecode= ptr target::subtag-macptr)
404  (bla .SPgets64)
405  (macptr-ptr imm2 ptr)
406  (unbox-fixnum imm3 offset)
407  (stdx imm0 imm3 imm2)
408  (ba .SPpopj))
409
410(defppclapfunction interrupt-level ()
411  (ldr arg_z target::tcr.tlb-pointer target::rcontext)
412  (ldr arg_z target::interrupt-level-binding-index arg_z)
413  (blr))
414
415
416(defppclapfunction disable-lisp-interrupts ()
417  (li imm0 '-1)
418  (ldr imm1 target::tcr.tlb-pointer target::rcontext)
419  (ldr arg_z target::interrupt-level-binding-index imm1)
420  (str imm0 target::interrupt-level-binding-index imm1)
421  (blr))
422
423(defppclapfunction set-interrupt-level ((new arg_z))
424  (ldr imm1 target::tcr.tlb-pointer target::rcontext)
425  (trap-unless-lisptag= new target::tag-fixnum imm0)
426  (str new target::interrupt-level-binding-index imm1)
427  (blr))
428
429;;; If we're restoring the interrupt level to 0 and an interrupt
430;;; was pending, restore the level to 1 and zero the pending status.
431(defppclapfunction restore-interrupt-level ((old arg_z))
432  (cmpri :cr1 old 0)
433  (ldr imm0 target::tcr.interrupt-pending target::rcontext)
434  (ldr imm1 target::tcr.tlb-pointer target::rcontext)
435  (cmpri :cr0 imm0 0)
436  (bne :cr1 @store)
437  (beq :cr0 @store)
438  (str rzero target::tcr.interrupt-pending target::rcontext)
439  (li old '1)
440  @store
441  (str old target::interrupt-level-binding-index imm1)
442  (blr))
443
444
445
446(defppclapfunction %current-tcr ()
447  (mr arg_z target::rcontext)
448  (blr))
449
450(defppclapfunction %tcr-toplevel-function ((tcr arg_z))
451  (check-nargs 1)
452  (cmpr tcr target::rcontext)
453  (mr imm0 vsp)
454  (ldr temp0 target::tcr.vs-area tcr)
455  (ldr imm1 target::area.high temp0)
456  (beq @room)
457  (ldr imm0 target::area.active temp0)
458  @room
459  (cmpr imm1 imm0)
460  (li arg_z nil)
461  (beqlr)
462  (ldr arg_z (- target::node-size) imm1)
463  (blr))
464
465(defppclapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z))
466  (check-nargs 2)
467  (cmpr tcr target::rcontext)
468  (mr imm0 vsp)
469  (ldr temp0 target::tcr.vs-area tcr)
470  (ldr imm1 target::area.high temp0)
471  (beq @check-room)
472  (ldr imm0 target::area.active temp0)
473  @check-room
474  (cmpr imm1 imm0)
475  (push rzero imm1)
476  (bne @have-room)
477  (str imm1 target::area.active temp0)
478  (str imm1 target::tcr.save-vsp tcr)
479  @have-room
480  (str fun 0 imm1)
481  (blr))
482
483;;; This needs to be done out-of-line, to handle EGC memoization.
484(defppclapfunction %store-node-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z))
485  (ba .SPstore-node-conditional))
486
487(defppclapfunction %store-immediate-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z))
488  (vpop temp0)
489  (unbox-fixnum imm0 temp0)
490  (let ((current temp1))
491    @again
492    (lrarx current object imm0)
493    (cmpr current old)
494    (bne @lose)
495    (strcx. new object imm0)
496    (bne @again)
497    (isync)
498    (li arg_z (+ target::t-offset (target-nil-value)))
499    (blr)
500    @lose
501    (li imm0 target::reservation-discharge)
502    (strcx. rzero rzero imm0)
503    (li arg_z nil)
504    (blr)))
505
506(defppclapfunction set-%gcable-macptrs% ((ptr target::arg_z))
507  (li imm0 (+ (target-nil-value) (target::kernel-global gcable-pointers)))
508  @again
509  (lrarx arg_y rzero imm0)
510  (str arg_y target::xmacptr.link ptr)
511  (strcx. ptr rzero imm0)
512  (bne @again)
513  (isync)
514  (blr))
515
516;;; Atomically increment or decrement the gc-inhibit-count kernel-global
517;;; (It's decremented if it's currently negative, incremented otherwise.)
518(defppclapfunction %lock-gc-lock ()
519  (li imm0 (+ (target-nil-value) (target::kernel-global gc-inhibit-count)))
520  @again
521  (lrarx arg_y rzero imm0)
522  (cmpri cr1 arg_y 0)
523  (addi arg_z arg_y '1)
524  (bge cr1 @store)
525  (subi arg_z arg_y '1)
526  @store
527  (strcx. arg_z rzero imm0)
528  (bne @again)
529;;  (isync)
530  (blr))
531
532;;; Atomically decrement or increment the gc-inhibit-count kernel-global
533;;; (It's incremented if it's currently negative, incremented otherwise.)
534;;; If it's incremented from -1 to 0, try to GC (maybe just a little.)
535(defppclapfunction %unlock-gc-lock ()
536;;  (sync)
537  (li imm0 (+ (target-nil-value) (target::kernel-global gc-inhibit-count)))
538  @again
539  (lrarx arg_y rzero imm0)
540  (cmpri cr1 arg_y -1)
541  (subi arg_z arg_y '1)
542  (bgt cr1 @store)
543  (addi arg_z arg_y '1)
544  @store
545  (strcx. arg_z rzero imm0)
546  (bne @again)
547  (bnelr cr1)
548  ;; The GC tried to run while it was inhibited.  Unless something else
549  ;; has just inhibited it, it should be possible to GC now.
550  (li imm0 arch::gc-trap-function-immediate-gc)
551  (trlgei allocptr 0)
552  (blr))
553
554
555
556(defppclapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
557  (check-nargs 3)
558  (unbox-fixnum imm1 disp)
559  @again
560  (lrarx arg_z node imm1)
561  (add arg_z arg_z by)
562  (strcx. arg_z node imm1)
563  (bne- @again)
564  (isync)
565  (blr))
566
567(defppclapfunction %atomic-incf-ptr ((ptr arg_z))
568  (macptr-ptr imm1 ptr)
569  @again
570  (lrarx imm0 0 imm1)
571  (addi imm0 imm0 1)
572  (strcx. imm0 0 imm1)
573  (bne @again)
574  (isync)
575  (box-fixnum arg_z imm0)
576  (blr))
577
578(defppclapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z))
579  (macptr-ptr imm1 ptr)
580  (unbox-fixnum imm2 by)
581  @again
582  (lrarx imm0 0 imm1)
583  (add imm0 imm0 imm2)
584  (strcx. imm0 0 imm1)
585  (bne @again)
586  (isync)
587  (box-fixnum arg_z imm0)
588  (blr))
589
590(defppclapfunction %atomic-decf-ptr ((ptr arg_z))
591  (macptr-ptr imm1 ptr)
592  @again
593  (lrarx imm0 0 imm1)
594  (subi imm0 imm0 1)
595  (strcx. imm0 0 imm1)
596  (bne @again)
597  (isync)
598  (box-fixnum arg_z imm0)
599  (blr))
600
601(defppclapfunction %atomic-decf-ptr-if-positive ((ptr arg_z))
602  (macptr-ptr imm1 ptr)
603  @again
604  (lrarx imm0 0 imm1)
605  (cmpri cr1 imm0 0)
606  (subi imm0 imm0 1)
607  (beq @done)
608  (strcx. imm0 0 imm1)
609  (bne @again)
610  (isync)
611  (box-fixnum arg_z imm0)
612  (blr)
613  @done
614  (li imm1 target::reservation-discharge)
615  (box-fixnum arg_z imm0)
616  (strcx. rzero rzero imm1)
617  (blr))
618
619(defppclapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z))
620  (sync)
621  (macptr-ptr imm1 ptr)
622  (unbox-fixnum imm2 arg_z)
623  @again
624  (lrarx imm0 0 imm1)
625  (strcx. imm2 0 imm1)
626  (bne @again)
627  (isync)
628  (box-fixnum arg_z imm0)
629  (blr))
630
631;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value
632;;; was equal to OLDVAL.  Return the old value
633(defppclapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
634  (macptr-ptr imm0 ptr)
635  (unbox-fixnum imm1 expected-oldval)
636  (unbox-fixnum imm2 newval)
637  @again
638  (lrarx imm3 0 imm0)
639  (cmpr imm3 imm1)
640  (bne- @done)
641  (strcx. imm2 0 imm0)
642  (bne- @again)
643  (isync)
644  (box-fixnum arg_z imm3)
645  (blr)
646  @done
647  (li imm0 target::reservation-discharge)
648  (box-fixnum arg_z imm3)
649  (strcx. rzero 0 imm0)
650  (blr))
651
652(defppclapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
653  (let ((address imm0)
654        (actual-oldval imm1))
655    (macptr-ptr address ptr)
656    @again
657    (lrarx actual-oldval 0 address)
658    (cmpr actual-oldval expected-oldval)
659    (bne- @done)
660    (strcx. newval 0 address)
661    (bne- @again)
662    (isync)
663    (mr arg_z actual-oldval)
664    (blr)
665    @done
666    (li address target::reservation-discharge)
667    (mr arg_z actual-oldval)
668    (strcx. rzero 0 address)
669    (blr)))
670
671
672
673
674(defppclapfunction %macptr->dead-macptr ((macptr arg_z))
675  (check-nargs 1)
676  (li imm0 target::subtag-dead-macptr)
677  (stb imm0 target::misc-subtag-offset macptr)
678  (blr))
679
680(defppclapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0)
681                                     (parent arg_x) (function arg_y) (arglist arg_z))
682  (check-nargs 7)
683
684  ; Throw through catch-count catch frames
685  (lwz imm0 12 vsp)                      ; catch-count
686  (vpush parent)
687  (vpush function)
688  (vpush arglist)
689  (bla .SPnthrowvalues)
690
691  ; Pop tsp-count TSP frames
692  (lwz tsp-count 16 vsp)
693  (cmpi cr0 tsp-count 0)
694  (b @test)
695@loop
696  (subi tsp-count tsp-count '1)
697  (cmpi cr0 tsp-count 0)
698  (lwz tsp 0 tsp)
699@test
700  (bne cr0 @loop)
701
702  ; Pop dynamic bindings until we get to db-link
703  (lwz imm0 12 vsp)                     ; db-link
704  (lwz imm1 target::tcr.db-link target::rcontext)
705  (cmp cr0 imm0 imm1)
706  (beq cr0 @restore-regs)               ; .SPunbind-to expects there to be something to do
707  (bla .SPunbind-to)
708
709@restore-regs
710  ; restore the saved registers from srv
711  (lwz srv 20 vsp)
712@get0
713  (svref imm0 1 srv)
714  (cmpwi cr0 imm0 (target-nil-value))
715  (beq @get1)
716  (lwz save0 0 imm0)
717@get1
718  (svref imm0 2 srv)
719  (cmpwi cr0 imm0 (target-nil-value))
720  (beq @get2)
721  (lwz save1 0 imm0)
722@get2
723  (svref imm0 3 srv)
724  (cmpwi cr0 imm0 (target-nil-value))
725  (beq @get3)
726  (lwz save2 0 imm0)
727@get3
728  (svref imm0 4 srv)
729  (cmpwi cr0 imm0 (target-nil-value))
730  (beq @get4)
731  (lwz save3 0 imm0)
732@get4
733  (svref imm0 5 srv)
734  (cmpwi cr0 imm0 (target-nil-value))
735  (beq @get5)
736  (lwz save4 0 imm0)
737@get5
738  (svref imm0 6 srv)
739  (cmpwi cr0 imm0 (target-nil-value))
740  (beq @get6)
741  (lwz save5 0 imm0)
742@get6
743  (svref imm0 7 srv)
744  (cmpwi cr0 imm0 (target-nil-value))
745  (beq @get7)
746  (lwz save6 0 imm0)
747@get7
748  (svref imm0 8 srv)
749  (cmpwi cr0 imm0 (target-nil-value))
750  (beq @got)
751  (lwz save7 0 imm0)
752@got
753
754  (vpop arg_z)                          ; arglist
755  (vpop temp0)                          ; function
756  (vpop parent)                         ; parent
757  (extract-lisptag imm0 parent)
758  (cmpi cr0 imm0 target::tag-fixnum)
759  (if (:cr0 :ne)
760    ; Parent is a fake-stack-frame. Make it real
761    (progn
762      (svref sp %fake-stack-frame.sp parent)
763      (stwu sp (- target::lisp-frame.size) sp)
764      (svref fn %fake-stack-frame.fn parent)
765      (stw fn target::lisp-frame.savefn sp)
766      (svref temp1 %fake-stack-frame.vsp parent)
767      (stw temp1 target::lisp-frame.savevsp sp)
768      (svref temp1 %fake-stack-frame.lr parent)
769      (extract-lisptag imm0 temp1)
770      (cmpi cr0 imm0 target::tag-fixnum)
771      (if (:cr0 :ne)
772        ;; must be a macptr encoding the actual link register
773        (macptr-ptr loc-pc temp1)
774        ;; Fixnum is offset from start of function vector
775        (progn
776          (svref temp2 0 fn)        ; function vector
777          (unbox-fixnum temp1 temp1)
778          (add loc-pc temp2 temp1)))
779      (stw loc-pc target::lisp-frame.savelr sp))
780    ;; Parent is a real stack frame
781    (mr sp parent))
782  (set-nargs 0)
783  (bla .SPspreadargz)
784  (ba .SPtfuncallgen))
785
786#+ppc32-target
787;;; Easiest to do this in lap, to avoid consing bignums and/or
788;;; multiple-value hair.
789;;; Bang through code-vector until the end or a 0 (traceback table
790;;; header) is found.  Return high-half, low-half of last instruction
791;;; and index where found.
792(defppclapfunction %code-vector-last-instruction ((cv arg_z))
793  (let ((previ imm0)
794        (nexti imm1)
795        (idx imm2)
796        (offset imm3)
797        (len imm4))
798    (vector-length len cv len)
799    (li idx 0)
800    (cmpw cr0 idx len)
801    (li offset target::misc-data-offset)
802    (li nexti 0)
803    (b @test)
804    @loop
805    (mr previ nexti)
806    (lwzx nexti cv offset)
807    (cmpwi cr1 nexti 0)
808    (addi idx idx '1)
809    (cmpw cr0 idx len)
810    (addi offset offset '1)
811    (beq cr1 @done)
812    @test
813    (bne cr0 @loop)
814    (mr previ nexti)
815    @done
816    (digit-h temp0 previ)
817    (digit-l temp1 previ)
818    (subi idx idx '1)
819    (vpush temp0)
820    (vpush temp1)
821    (vpush idx)
822    (set-nargs 3)
823    (la temp0 '3 vsp)
824    (ba .SPvalues)))
825
826#+ppc64-target
827(defun %code-vector-last-instruction (cv)
828  (do* ((i 1 (1+ i))
829        (instr nil)
830        (n (uvsize cv)))
831       ((= i n) instr)
832    (declare (fixnum i n))
833    (let* ((next (uvref cv i)))
834      (declare (type (unsigned-byte 32) next))
835      (if (zerop next)
836        (return instr)
837        (setq instr next)))))
838
839       
840
841 
842(defppclapfunction %%save-application ((flags arg_y) (fd arg_z))
843  (unbox-fixnum imm0 flags)
844  (ori imm0 imm0 arch::gc-trap-function-save-application)
845  (unbox-fixnum imm1 fd)
846  (trlgei allocptr 0)
847  (blr))
848
849
850
851(defppclapfunction %misc-address-fixnum ((misc-object arg_z))
852  (check-nargs 1)
853  (la arg_z target::misc-data-offset misc-object)
854  (blr))
855
856
857#+ppc32-target
858(defppclapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z))
859  (check-nargs 3)
860  (macptr-ptr imm1 ptr) ; address in macptr
861  (addi imm0 imm1 9)     ; 2 for delta + 7 for alignment
862  (clrrwi imm0 imm0 3)   ; Clear low three bits to align
863  (subf imm1 imm1 imm0)  ; imm1 = delta
864  (sth imm1 -2 imm0)     ; save delta halfword
865  (unbox-fixnum imm1 subtype)  ; subtype at low end of imm1
866  (rlwimi imm1 len (- target::num-subtag-bits target::fixnum-shift) 0 (- 31 target::num-subtag-bits))
867  (stw imm1 0 imm0)       ; store subtype & length
868  (addi arg_z imm0 target::fulltag-misc) ; tag it, return it
869  (blr))
870
871#+ppc64-target
872(defppclapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z))
873  (check-nargs 3)
874  (macptr-ptr imm1 ptr) ; address in macptr
875  (addi imm0 imm1 17)     ; 2 for delta + 15 for alignment
876  (clrrdi imm0 imm0 4)   ; Clear low four bits to align
877  (subf imm1 imm1 imm0)  ; imm1 = delta
878  (sth imm1 -2 imm0)     ; save delta halfword
879  (unbox-fixnum imm1 subtype)  ; subtype at low end of imm1
880  (sldi imm2 len (- target::num-subtag-bits target::fixnum-shift))
881  (or imm1 imm2 imm1)
882  (std imm1 0 imm0)       ; store subtype & length
883  (addi arg_z imm0 target::fulltag-misc) ; tag it, return it
884  (blr))
885
886(defppclapfunction %%make-disposable ((ptr arg_y) (vector arg_z))
887  (check-nargs 2)
888  (subi imm0 vector target::fulltag-misc) ; imm0 is addr = vect less tag
889  (lhz imm1 -2 imm0)   ; get delta
890  (sub imm0 imm0 imm1)  ; vector addr (less tag)  - delta is orig addr
891  (str imm0 target::macptr.address ptr) 
892  (blr))
893
894#+ppc32-target
895(defppclapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z))
896  ;; put address of vect data in macptr.  For all vector types
897  ;; other than DOUBLE-FLOAT (or vectors thereof), the first byte
898  ;; of data is at PPC32::MISC-DATA-OFFSET; for the double-float
899  ;; types, it's at PPC32::MISC-DFLOAT-OFFSET.
900  (extract-subtag imm0 vect)
901  (cmpwi cr0 imm0 ppc32::subtag-double-float-vector)
902  (cmpwi cr1 imm0 ppc32::subtag-double-float)
903  (addi temp0 vect ppc32::misc-data-offset)
904  (beq cr0 @dfloat)
905  (beq cr1 @dfloat)
906  (stw temp0 ppc32::macptr.address arg_z)
907  (blr)
908  @dfloat
909  (addi temp0 vect ppc32::misc-dfloat-offset)
910  (stw temp0 ppc32::macptr.address arg_z)
911  (blr))
912
913#+ppc64-target
914(defppclapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z))
915  (la imm0 ppc64::misc-data-offset vect)
916  (std imm0 ppc64::macptr.address ptr)
917  (blr))
918
919(defppclapfunction get-saved-register-values ()
920  (vpush save0)
921  (vpush save1)
922  (vpush save2)
923  (vpush save3)
924  (vpush save4)
925  (vpush save5)
926  (vpush save6)
927  (vpush save7)
928  (la temp0 (* 8 target::node-size) vsp)
929  (set-nargs 8)
930  (ba .SPvalues))
931
932
933(defppclapfunction %current-db-link ()
934  (ldr arg_z target::tcr.db-link target::rcontext)
935  (blr))
936
937(defppclapfunction %no-thread-local-binding-marker ()
938  (li arg_z target::subtag-no-thread-local-binding)
939  (blr))
940
941
942(defppclapfunction pending-user-interrupt ()
943  (ref-global arg_z target::intflag)
944  ;; If another signal happens now, it will get ignored, same as if it happened
945  ;; before whatever signal is in arg_z.  But then these are async signals, so
946  ;; who can be sure it didn't actually happen just before...
947  (set-global rzero target::intflag)
948  (blr))
949
950
951;;; Should be called with interrupts disabled.
952(defppclapfunction %safe-get-ptr ((src arg_y) (dest arg_z))
953  (check-nargs 2)
954  (macptr-ptr imm0 src)
955  (str imm0 target::tcr.safe-ref-address target::rcontext)
956  (ldr imm0 0 imm0)                     ; may fault
957  (str imm0 target::macptr.address dest)
958  (blr))
959
960
961
962;;; r13 contains thread context on Linux/Darwin PPC64.
963;;; That's maintained in r2 on LinuxPPC32, and not maintained
964;;; in a GPR on DarwinPPC32
965(defppclapfunction %get-os-context ()
966  #+ppc64-target (mr arg_z 13)
967  #+linuxppc32-target (mr arg_z 2)
968  #+darinppc32-target (mr arg_z 0)
969  (blr))
970
971(defppclapfunction %check-deferred-gc ()
972  (ldr imm0 target::tcr.flags target::rcontext)
973  (slri. imm0 imm0 (- (1- target::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)))
974  (li arg_z nil)
975  (bgelr)
976  (uuo_interr arch::error-propagate-suspend rzero)
977  (li arg_z t)
978  (blr))
979
980(defppclapfunction %%tcr-interrupt ((target arg_z))
981  (check-nargs 1)
982  (uuo_interr arch::error-interrupt rzero)
983  (box-fixnum arg_z imm0)
984  (blr))
985
986(defppclapfunction %suspend-tcr ((target arg_z))
987  (check-nargs 1)
988  (uuo_interr arch::error-suspend rzero)
989  (ne0->boolean arg_z imm0 imm1)
990  (blr))
991
992(defppclapfunction %suspend-other-threads ()
993  (check-nargs 0)
994  (uuo_interr arch::error-suspend-all rzero)
995  (li arg_z nil)
996  (blr))
997
998(defppclapfunction %resume-tcr ((target arg_z))
999  (check-nargs 1)
1000  (uuo_interr arch::error-resume rzero)
1001  (ne0->boolean arg_z imm0 imm1)
1002  (blr))
1003
1004(defppclapfunction %resume-other-threads ()
1005  (check-nargs 0)
1006  (uuo_interr arch::error-resume-all rzero)
1007  (li arg_z nil)
1008  (blr))
1009
1010(defppclapfunction %kill-tcr ((target arg_z))
1011  (check-nargs 1)
1012  (uuo_interr arch::error-kill rzero)
1013  (ne0->boolean arg_z imm0 imm1)
1014  (blr))
1015
1016(defppclapfunction %atomic-pop-static-cons ()
1017  (li imm0 (+ (target-nil-value) (target::kernel-global static-conses)))
1018  @again
1019  (lrarx arg_z rzero imm0)
1020  (cmpri arg_z (target-nil-value))
1021  (beq @lose)
1022  (%cdr arg_y arg_z)
1023  (strcx. arg_y rzero imm0)
1024  (bne @again)
1025  (li imm0 (+ (target-nil-value) (target::kernel-global free-static-conses)))
1026  @decf
1027  (lrarx imm1 rzero imm0)
1028  (subi imm1 imm1 '1)
1029  (strcx. imm1 rzero imm0)
1030  (bne @decf)
1031  (isync)
1032  (blr)
1033  @lose
1034  (li imm0 target::reservation-discharge)
1035  (strcx. rzero rzero imm0)
1036  (blr))
1037
1038
1039
1040(defppclapfunction %staticp ((x arg_z))
1041  (check-nargs 1)
1042  (ref-global temp0 static-cons-area)
1043  (ldr imm1 target::area.low temp0)
1044  (sub imm0 x imm1)
1045  (ldr imm1 target::area.ndnodes temp0)
1046  (srri imm0 imm0 target::dnode-shift)
1047  (li arg_z nil)
1048  (sub imm1 imm1 imm0)
1049  (cmplri imm1 0)
1050  (la imm1 128 imm1)
1051  (blelr)
1052  (box-fixnum arg_z imm1)
1053  (blr))
1054
1055(defppclapfunction %static-inverse-cons ((n arg_z))
1056  (check-nargs 1)
1057  (extract-lisptag imm0 arg_z)
1058  (cmpri imm0 0)
1059  (ref-global temp0 static-cons-area)
1060  (bne @fail)
1061  (la n '-128 n)
1062  (ldr imm0 target::area.ndnodes temp0)
1063  (ldr imm1 target::area.high temp0)
1064  (box-fixnum arg_y imm0)
1065  (sub imm1 imm1 n)
1066  (cmplr arg_z arg_y)
1067  (sub imm1 imm1 n)
1068  (bgt @fail)
1069  (la arg_z target::fulltag-cons imm1)
1070  (ldr arg_y target::cons.car arg_z)
1071  (cmpri arg_y target::unbound-marker)
1072  (bnelr)
1073  @fail
1074  (li arg_z nil)
1075  (blr))
1076 
1077
1078; end of ppc-misc.lisp
Note: See TracBrowser for help on using the repository browser.