source: release/1.3/source/level-0/PPC/ppc-misc.lisp @ 11704

Last change on this file since 11704 was 11704, checked in by rme, 11 years ago

Merge r11703 from trunk.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.8 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
554
555(defppclapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
556  (check-nargs 3)
557  (unbox-fixnum imm1 disp)
558  @again
559  (lrarx arg_z node imm1)
560  (add arg_z arg_z by)
561  (strcx. arg_z node imm1)
562  (bne- @again)
563  (isync)
564  (blr))
565
566(defppclapfunction %atomic-incf-ptr ((ptr arg_z))
567  (macptr-ptr imm1 ptr)
568  @again
569  (lrarx imm0 0 imm1)
570  (addi imm0 imm0 1)
571  (strcx. imm0 0 imm1)
572  (bne @again)
573  (isync)
574  (box-fixnum arg_z imm0)
575  (blr))
576
577(defppclapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z))
578  (macptr-ptr imm1 ptr)
579  (unbox-fixnum imm2 by)
580  @again
581  (lrarx imm0 0 imm1)
582  (add imm0 imm0 imm2)
583  (strcx. imm0 0 imm1)
584  (bne @again)
585  (isync)
586  (box-fixnum arg_z imm0)
587  (blr))
588
589(defppclapfunction %atomic-decf-ptr ((ptr arg_z))
590  (macptr-ptr imm1 ptr)
591  @again
592  (lrarx imm0 0 imm1)
593  (subi imm0 imm0 1)
594  (strcx. imm0 0 imm1)
595  (bne @again)
596  (isync)
597  (box-fixnum arg_z imm0)
598  (blr))
599
600(defppclapfunction %atomic-decf-ptr-if-positive ((ptr arg_z))
601  (macptr-ptr imm1 ptr)
602  @again
603  (lrarx imm0 0 imm1)
604  (cmpri cr1 imm0 0)
605  (subi imm0 imm0 1)
606  (beq @done)
607  (strcx. imm0 0 imm1)
608  (bne @again)
609  (isync)
610  (box-fixnum arg_z imm0)
611  (blr)
612  @done
613  (li imm1 target::reservation-discharge)
614  (box-fixnum arg_z imm0)
615  (strcx. rzero rzero imm1)
616  (blr))
617
618(defppclapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z))
619  (sync)
620  (macptr-ptr imm1 ptr)
621  (unbox-fixnum imm2 arg_z)
622  @again
623  (lrarx imm0 0 imm1)
624  (strcx. imm2 0 imm1)
625  (bne @again)
626  (isync)
627  (box-fixnum arg_z imm0)
628  (blr))
629
630;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value
631;;; was equal to OLDVAL.  Return the old value
632(defppclapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
633  (macptr-ptr imm0 ptr)
634  (unbox-fixnum imm1 expected-oldval)
635  (unbox-fixnum imm2 newval)
636  @again
637  (lrarx imm3 0 imm0)
638  (cmpr imm3 imm1)
639  (bne- @done)
640  (strcx. imm2 0 imm0)
641  (bne- @again)
642  (isync)
643  (box-fixnum arg_z imm3)
644  (blr)
645  @done
646  (li imm0 target::reservation-discharge)
647  (box-fixnum arg_z imm3)
648  (strcx. rzero 0 imm0)
649  (blr))
650
651(defppclapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
652  (let ((address imm0)
653        (actual-oldval imm1))
654    (macptr-ptr address ptr)
655    @again
656    (lrarx actual-oldval 0 address)
657    (cmpr actual-oldval expected-oldval)
658    (bne- @done)
659    (strcx. newval 0 address)
660    (bne- @again)
661    (isync)
662    (mr arg_z actual-oldval)
663    (blr)
664    @done
665    (li address target::reservation-discharge)
666    (mr arg_z actual-oldval)
667    (strcx. rzero 0 address)
668    (blr)))
669
670
671
672
673(defppclapfunction %macptr->dead-macptr ((macptr arg_z))
674  (check-nargs 1)
675  (li imm0 target::subtag-dead-macptr)
676  (stb imm0 target::misc-subtag-offset macptr)
677  (blr))
678
679(defppclapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0)
680                                     (parent arg_x) (function arg_y) (arglist arg_z))
681  (check-nargs 7)
682
683  ; Throw through catch-count catch frames
684  (lwz imm0 12 vsp)                      ; catch-count
685  (vpush parent)
686  (vpush function)
687  (vpush arglist)
688  (bla .SPnthrowvalues)
689
690  ; Pop tsp-count TSP frames
691  (lwz tsp-count 16 vsp)
692  (cmpi cr0 tsp-count 0)
693  (b @test)
694@loop
695  (subi tsp-count tsp-count '1)
696  (cmpi cr0 tsp-count 0)
697  (lwz tsp 0 tsp)
698@test
699  (bne cr0 @loop)
700
701  ; Pop dynamic bindings until we get to db-link
702  (lwz imm0 12 vsp)                     ; db-link
703  (lwz imm1 target::tcr.db-link target::rcontext)
704  (cmp cr0 imm0 imm1)
705  (beq cr0 @restore-regs)               ; .SPunbind-to expects there to be something to do
706  (bla .SPunbind-to)
707
708@restore-regs
709  ; restore the saved registers from srv
710  (lwz srv 20 vsp)
711@get0
712  (svref imm0 1 srv)
713  (cmpwi cr0 imm0 (target-nil-value))
714  (beq @get1)
715  (lwz save0 0 imm0)
716@get1
717  (svref imm0 2 srv)
718  (cmpwi cr0 imm0 (target-nil-value))
719  (beq @get2)
720  (lwz save1 0 imm0)
721@get2
722  (svref imm0 3 srv)
723  (cmpwi cr0 imm0 (target-nil-value))
724  (beq @get3)
725  (lwz save2 0 imm0)
726@get3
727  (svref imm0 4 srv)
728  (cmpwi cr0 imm0 (target-nil-value))
729  (beq @get4)
730  (lwz save3 0 imm0)
731@get4
732  (svref imm0 5 srv)
733  (cmpwi cr0 imm0 (target-nil-value))
734  (beq @get5)
735  (lwz save4 0 imm0)
736@get5
737  (svref imm0 6 srv)
738  (cmpwi cr0 imm0 (target-nil-value))
739  (beq @get6)
740  (lwz save5 0 imm0)
741@get6
742  (svref imm0 7 srv)
743  (cmpwi cr0 imm0 (target-nil-value))
744  (beq @get7)
745  (lwz save6 0 imm0)
746@get7
747  (svref imm0 8 srv)
748  (cmpwi cr0 imm0 (target-nil-value))
749  (beq @got)
750  (lwz save7 0 imm0)
751@got
752
753  (vpop arg_z)                          ; arglist
754  (vpop temp0)                          ; function
755  (vpop parent)                         ; parent
756  (extract-lisptag imm0 parent)
757  (cmpi cr0 imm0 target::tag-fixnum)
758  (if (:cr0 :ne)
759    ; Parent is a fake-stack-frame. Make it real
760    (progn
761      (svref sp %fake-stack-frame.sp parent)
762      (stwu sp (- target::lisp-frame.size) sp)
763      (svref fn %fake-stack-frame.fn parent)
764      (stw fn target::lisp-frame.savefn sp)
765      (svref temp1 %fake-stack-frame.vsp parent)
766      (stw temp1 target::lisp-frame.savevsp sp)
767      (svref temp1 %fake-stack-frame.lr parent)
768      (extract-lisptag imm0 temp1)
769      (cmpi cr0 imm0 target::tag-fixnum)
770      (if (:cr0 :ne)
771        ;; must be a macptr encoding the actual link register
772        (macptr-ptr loc-pc temp1)
773        ;; Fixnum is offset from start of function vector
774        (progn
775          (svref temp2 0 fn)        ; function vector
776          (unbox-fixnum temp1 temp1)
777          (add loc-pc temp2 temp1)))
778      (stw loc-pc target::lisp-frame.savelr sp))
779    ;; Parent is a real stack frame
780    (mr sp parent))
781  (set-nargs 0)
782  (bla .SPspreadargz)
783  (ba .SPtfuncallgen))
784
785#+ppc32-target
786;;; Easiest to do this in lap, to avoid consing bignums and/or
787;;; multiple-value hair.
788;;; Bang through code-vector until the end or a 0 (traceback table
789;;; header) is found.  Return high-half, low-half of last instruction
790;;; and index where found.
791(defppclapfunction %code-vector-last-instruction ((cv arg_z))
792  (let ((previ imm0)
793        (nexti imm1)
794        (idx imm2)
795        (offset imm3)
796        (len imm4))
797    (vector-length len cv len)
798    (li idx 0)
799    (cmpw cr0 idx len)
800    (li offset target::misc-data-offset)
801    (li nexti 0)
802    (b @test)
803    @loop
804    (mr previ nexti)
805    (lwzx nexti cv offset)
806    (cmpwi cr1 nexti 0)
807    (addi idx idx '1)
808    (cmpw cr0 idx len)
809    (addi offset offset '1)
810    (beq cr1 @done)
811    @test
812    (bne cr0 @loop)
813    (mr previ nexti)
814    @done
815    (digit-h temp0 previ)
816    (digit-l temp1 previ)
817    (subi idx idx '1)
818    (vpush temp0)
819    (vpush temp1)
820    (vpush idx)
821    (set-nargs 3)
822    (la temp0 '3 vsp)
823    (ba .SPvalues)))
824
825#+ppc64-target
826(defun %code-vector-last-instruction (cv)
827  (do* ((i 1 (1+ i))
828        (instr nil)
829        (n (uvsize cv)))
830       ((= i n) instr)
831    (declare (fixnum i n))
832    (let* ((next (uvref cv i)))
833      (declare (type (unsigned-byte 32) next))
834      (if (zerop next)
835        (return instr)
836        (setq instr next)))))
837
838       
839
840 
841(defppclapfunction %%save-application ((flags arg_y) (fd arg_z))
842  (unbox-fixnum imm0 flags)
843  (ori imm0 imm0 arch::gc-trap-function-save-application)
844  (unbox-fixnum imm1 fd)
845  (trlgei allocptr 0)
846  (blr))
847
848(defppclapfunction %metering-info ((ptr arg_z))
849  (ref-global imm0 metering-info)
850  (stw imm0 target::macptr.address ptr)
851  (blr))
852
853(defppclapfunction %misc-address-fixnum ((misc-object arg_z))
854  (check-nargs 1)
855  (la arg_z target::misc-data-offset misc-object)
856  (blr))
857
858
859#+ppc32-target
860(defppclapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z))
861  (check-nargs 3)
862  (macptr-ptr imm1 ptr) ; address in macptr
863  (addi imm0 imm1 9)     ; 2 for delta + 7 for alignment
864  (clrrwi imm0 imm0 3)   ; Clear low three bits to align
865  (subf imm1 imm1 imm0)  ; imm1 = delta
866  (sth imm1 -2 imm0)     ; save delta halfword
867  (unbox-fixnum imm1 subtype)  ; subtype at low end of imm1
868  (rlwimi imm1 len (- target::num-subtag-bits target::fixnum-shift) 0 (- 31 target::num-subtag-bits))
869  (stw imm1 0 imm0)       ; store subtype & length
870  (addi arg_z imm0 target::fulltag-misc) ; tag it, return it
871  (blr))
872
873#+ppc64-target
874(defppclapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z))
875  (check-nargs 3)
876  (macptr-ptr imm1 ptr) ; address in macptr
877  (addi imm0 imm1 17)     ; 2 for delta + 15 for alignment
878  (clrrdi imm0 imm0 4)   ; Clear low four bits to align
879  (subf imm1 imm1 imm0)  ; imm1 = delta
880  (sth imm1 -2 imm0)     ; save delta halfword
881  (unbox-fixnum imm1 subtype)  ; subtype at low end of imm1
882  (sldi imm2 len (- target::num-subtag-bits target::fixnum-shift))
883  (or imm1 imm2 imm1)
884  (std imm1 0 imm0)       ; store subtype & length
885  (addi arg_z imm0 target::fulltag-misc) ; tag it, return it
886  (blr))
887
888(defppclapfunction %%make-disposable ((ptr arg_y) (vector arg_z))
889  (check-nargs 2)
890  (subi imm0 vector target::fulltag-misc) ; imm0 is addr = vect less tag
891  (lhz imm1 -2 imm0)   ; get delta
892  (sub imm0 imm0 imm1)  ; vector addr (less tag)  - delta is orig addr
893  (str imm0 target::macptr.address ptr) 
894  (blr))
895
896#+ppc32-target
897(defppclapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z))
898  ;; put address of vect data in macptr.  For all vector types
899  ;; other than DOUBLE-FLOAT (or vectors thereof), the first byte
900  ;; of data is at PPC32::MISC-DATA-OFFSET; for the double-float
901  ;; types, it's at PPC32::MISC-DFLOAT-OFFSET.
902  (extract-subtag imm0 vect)
903  (cmpwi cr0 imm0 ppc32::subtag-double-float-vector)
904  (cmpwi cr1 imm0 ppc32::subtag-double-float)
905  (addi temp0 vect ppc32::misc-data-offset)
906  (beq cr0 @dfloat)
907  (beq cr1 @dfloat)
908  (stw temp0 ppc32::macptr.address arg_z)
909  (blr)
910  @dfloat
911  (addi temp0 vect ppc32::misc-dfloat-offset)
912  (stw temp0 ppc32::macptr.address arg_z)
913  (blr))
914
915#+ppc64-target
916(defppclapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z))
917  (la imm0 ppc64::misc-data-offset vect)
918  (std imm0 ppc64::macptr.address ptr)
919  (blr))
920
921(defppclapfunction get-saved-register-values ()
922  (vpush save0)
923  (vpush save1)
924  (vpush save2)
925  (vpush save3)
926  (vpush save4)
927  (vpush save5)
928  (vpush save6)
929  (vpush save7)
930  (la temp0 (* 8 target::node-size) vsp)
931  (set-nargs 8)
932  (ba .SPvalues))
933
934
935(defppclapfunction %current-db-link ()
936  (ldr arg_z target::tcr.db-link target::rcontext)
937  (blr))
938
939(defppclapfunction %no-thread-local-binding-marker ()
940  (li arg_z target::subtag-no-thread-local-binding)
941  (blr))
942
943
944(defppclapfunction pending-user-interrupt ()
945  (ref-global arg_z target::intflag)
946  ;; If another signal happens now, it will get ignored, same as if it happened
947  ;; before whatever signal is in arg_z.  But then these are async signals, so
948  ;; who can be sure it didn't actually happen just before...
949  (set-global rzero target::intflag)
950  (blr))
951
952
953;;; Should be called with interrupts disabled.
954(defppclapfunction %safe-get-ptr ((src arg_y) (dest arg_z))
955  (check-nargs 2)
956  (macptr-ptr imm0 src)
957  (str imm0 target::tcr.safe-ref-address target::rcontext)
958  (ldr imm0 0 imm0)                     ; may fault
959  (str imm0 target::macptr.address dest)
960  (blr))
961
962
963
964;;; r13 contains thread context on Linux/Darwin PPC64.
965;;; That's maintained in r2 on LinuxPPC32, and not maintained
966;;; in a GPR on DarwinPPC32
967(defppclapfunction %get-os-context ()
968  #+ppc64-target (mr arg_z 13)
969  #+linuxppc32-target (mr arg_z 2)
970  #+darinppc32-target (mr arg_z 0)
971  (blr))
972
973(defppclapfunction %check-deferred-gc ()
974  (ldr imm0 target::tcr.flags target::rcontext)
975  (slri. imm0 imm0 (- (1- target::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)))
976  (li arg_z nil)
977  (bgelr)
978  (uuo_interr arch::error-propagate-suspend rzero)
979  (li arg_z t)
980  (blr))
981
982(defppclapfunction %%tcr-interrupt ((target arg_z))
983  (check-nargs 1)
984  (uuo_interr arch::error-interrupt rzero)
985  (box-fixnum arg_z imm0)
986  (blr))
987
988(defppclapfunction %suspend-tcr ((target arg_z))
989  (check-nargs 1)
990  (uuo_interr arch::error-suspend rzero)
991  (ne0->boolean arg_z imm0 imm1)
992  (blr))
993
994(defppclapfunction %suspend-other-threads ()
995  (check-nargs 0)
996  (uuo_interr arch::error-suspend-all rzero)
997  (li arg_z nil)
998  (blr))
999
1000(defppclapfunction %resume-tcr ((target arg_z))
1001  (check-nargs 1)
1002  (uuo_interr arch::error-resume rzero)
1003  (ne0->boolean arg_z imm0 imm1)
1004  (blr))
1005
1006(defppclapfunction %resume-other-threads ()
1007  (check-nargs 0)
1008  (uuo_interr arch::error-resume-all rzero)
1009  (li arg_z nil)
1010  (blr))
1011
1012(defppclapfunction %kill-tcr ((target arg_z))
1013  (check-nargs 1)
1014  (uuo_interr arch::error-kill rzero)
1015  (ne0->boolean arg_z imm0 imm1)
1016  (blr))
1017
1018(defppclapfunction %atomic-pop-static-cons ()
1019  (li imm0 (+ (target-nil-value) (target::kernel-global static-conses)))
1020  @again
1021  (lrarx arg_z rzero imm0)
1022  (cmpri arg_z (target-nil-value))
1023  (beq @lose)
1024  (%cdr arg_y arg_z)
1025  (strcx. arg_y rzero imm0)
1026  (isync)
1027  (bne @again)
1028  (blr)
1029  @lose
1030  (li imm0 target::reservation-discharge)
1031  (strcx. rzero rzero imm0)
1032  (blr))
1033
1034(defppclapfunction %augment-static-conses ((head arg_y) (tail arg_z))
1035  (li imm0 (+ (target-nil-value) (target::kernel-global static-conses)))
1036  @again
1037  (lrarx temp0 rzero imm0)
1038  (str temp0 target::cons.cdr tail)     ; static, no write-barrier issues
1039  (strcx. head rzero imm0)
1040  (bne @again)
1041  (isync)
1042  (li arg_z nil)
1043  (blr))
1044
1045(defppclapfunction %staticp ((x arg_z))
1046  (check-nargs 1)
1047  (ref-global temp0 tenured-area)
1048  (ldr imm1 target::area.low temp0)
1049  (sub imm0 x imm1)
1050  (ldr imm1 target::area.static-dnodes temp0)
1051  (srri imm0 imm0 target::dnode-shift)
1052  (li arg_z nil)
1053  (cmplr imm0 imm1)
1054  (bgelr)
1055  (box-fixnum arg_z imm0)
1056  (blr))
1057
1058(defppclapfunction %static-inverse-cons ((n arg_z))
1059  (check-nargs 1)
1060  (ref-global temp0 tenured-area)
1061  (ldr imm1 target::area.low temp0)
1062  (add imm1 n imm1)
1063  (add imm1 n imm1)
1064  (la arg_z target::fulltag-cons imm1)
1065  (blr))
1066 
1067
1068; end of ppc-misc.lisp
Note: See TracBrowser for help on using the repository browser.