source: branches/objc-gf/ccl/level-0/PPC/ppc-misc.lisp @ 6066

Last change on this file since 6066 was 6066, checked in by gb, 13 years ago

%ptr-store-fixnum-conditional.

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