source: trunk/source/level-0/PPC/ppc-array.lisp @ 13919

Last change on this file since 13919 was 13919, checked in by rme, 10 years ago

In %INIT-MISC at label @8, the subtag of the destination vector is imm2,
not imm0 (which contains the typecode of the initial element).

This caused the tests print.array.0.15 and print.array.2.29 to fail.

This bug is dormant in pre-1.5 releases; r13410 appears to have
uncovered it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 23.7 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(in-package "CCL")
19
20(eval-when (:compile-toplevel :execute)
21  #+ppc32-target
22  (require "PPC32-ARCH")
23  #+ppc64-target
24  (require "PPC64-ARCH")
25  (require "PPC-LAPMACROS"))
26
27
28;;; Users of this shouldn't make assumptions about return value.
29
30
31#+ppc32-target
32(eval-when (:compile-toplevel :execute)
33;;; Assumptions made by %init-misc
34  (assert (and (< ppc32::max-32-bit-ivector-subtag
35                  ppc32::max-8-bit-ivector-subtag
36                  ppc32::max-16-bit-ivector-subtag)
37               (eql ppc32::max-32-bit-ivector-subtag ppc32::subtag-simple-base-string)
38               (eql ppc32::max-16-bit-ivector-subtag ppc32::subtag-s16-vector)
39               (eql ppc32::max-8-bit-ivector-subtag 223))))
40
41#+ppc32-target
42(defppclapfunction %init-misc ((val arg_y)
43                               (miscobj arg_z))
44  (getvheader imm0 miscobj)
45  (header-size imm3 imm0)
46  (cmpwi cr3 imm3 0)
47  (extract-fulltag imm1 imm0)
48  (cmpwi cr0 imm1 ppc32::fulltag-nodeheader)
49  (extract-lowbyte imm2 imm0)
50  (beqlr cr3)                           ; Silly 0-length case
51  (li imm4 ppc32::misc-data-offset)
52  (bne cr0 @imm)
53  ; Node vector.  Don't need to memoize, since initial value is
54  ; older than vector.
55  @node-loop
56  (cmpwi cr0 imm3 1)
57  (subi imm3 imm3 1)
58  (stwx val miscobj imm4)
59  (la imm4 4 imm4)
60  (bne cr0 @node-loop)
61  (blr)
62  @imm
63  (cmpwi cr0 imm2 ppc32::subtag-double-float-vector)
64  (cmpwi cr1 imm2 ppc32::max-32-bit-ivector-subtag)
65  (cmpwi cr2 imm2 ppc32::max-8-bit-ivector-subtag)
66  (cmpwi cr3 imm2 ppc32::max-16-bit-ivector-subtag)
67  (extract-typecode imm0 val :CR6)              ; don't clobber CR0
68  (cmpwi cr7 imm0 ppc32::tag-fixnum)
69  (beq cr0 @dfloat)
70  (ble cr1 @32)
71  (ble cr2 @8)
72  (ble cr3 @16)
73  ; Bit vector.
74  (cmplwi cr0 val '1)
75  (la imm3 31 imm3)
76  (srwi imm3 imm3 5)
77  (unbox-fixnum imm0 val)
78  (neg imm0 imm0)
79  (ble+ cr0 @set-32)
80  @bad
81  (li arg_x '#.$xnotelt)
82  (save-lisp-context)
83  (set-nargs 3)
84  (call-symbol %err-disp)
85  @dfloat
86  (cmpwi cr0 imm0 ppc32::subtag-double-float)
87  (li imm4 ppc32::misc-dfloat-offset)
88  (bne- cr0 @bad)
89  (lfd fp0 ppc32::double-float.value val)
90  @dfloat-loop
91  (cmpwi cr0 imm3 1)
92  (subi imm3 imm3 1)
93  (stfdx fp0 miscobj imm4)
94  (la imm4 8 imm4)
95  (bne cr0 @dfloat-loop)
96  (blr)
97  @32
98  (cmpwi cr4 imm2 ppc32::subtag-s32-vector)
99  (cmpwi cr0 imm2 ppc32::subtag-single-float-vector)
100  (cmpwi cr2 imm0 ppc32::subtag-bignum)
101  (cmpwi cr3 imm2 ppc32::subtag-fixnum-vector)
102  (beq cr1 @char32)                      ; ppc32::max-32-bit-ivector-subtag
103  (beq cr4 @s32)
104  (beq cr3 @fixnum)
105  (bne cr0 @u32)
106  ;@sfloat
107  (cmpwi cr0 imm0 ppc32::subtag-single-float)
108  (bne- cr0 @bad)
109  (lwz imm0 ppc32::single-float.value val)
110  (b @set-32)
111  @fixnum
112  (unbox-fixnum imm0 val)
113  (beq+ cr7 @set-32)
114  (b @bad)
115  @char32
116  (unbox-base-char imm0 val cr0)
117  (b @set-32)
118  @s32
119  (unbox-fixnum imm0 val)
120  (beq+ cr7 @set-32)
121  (bne- cr2 @bad)
122  (getvheader imm0 val)
123  (cmpwi cr0 imm0 (logior (ash 1 ppc32::num-subtag-bits) ppc32::subtag-bignum))
124  (lwz imm0 ppc32::misc-data-offset val)
125  (beq+ cr0 @set-32)
126  (b @bad)
127  @u32
128  (extract-unsigned-byte-bits. imm0 val 30)
129  (unbox-fixnum imm0 val)
130  (beq cr0 @set-32)
131  (bne- cr2 @bad)
132  ; a one-digit bignum is ok if that digit is positive.
133  ; a two-digit bignum is ok if the sign-digit is 0.
134  (getvheader imm0 val)
135  (cmpwi cr2 imm0 (logior (ash 2 ppc32::num-subtag-bits) ppc32::subtag-bignum))
136  (lwz imm0 ppc32::misc-data-offset val)
137  (cmpwi cr3 imm0 0)
138  (bgt- cr2 @bad)                       ; more than two digits.
139  (beq cr2 @two-digits)
140  (bgt+ cr3 @set-32)
141  (b @bad)
142  @two-digits
143  (lwz imm1 (+ 4 ppc32::misc-data-offset) val)
144  (cmpwi cr0 imm1 0)
145  (bne- cr0 @bad)
146  (b @set-32)
147  @16
148  (cmpwi cr0 imm2 ppc32::subtag-u16-vector)
149  (la imm3 1 imm3)
150  (srwi imm3 imm3 1)
151  (beq cr3 @s16)                        ; ppc32::max-16-bit-ivector-subtag
152  (extract-unsigned-byte-bits. imm0 val 16)
153  (unbox-fixnum imm0 val)
154  (beq+ cr0 @set-16)
155  (b @bad)
156  @s16
157  (slwi imm0 val (- 32 (+ 16 ppc32::fixnumshift)))
158  (srawi imm0 imm0 (- 32 (+ 16 ppc32::fixnumshift)))
159  (cmpw cr0 imm0 val)
160  (unbox-fixnum imm0 val)
161  (bne- cr7 @bad)
162  (beq+ cr0 @set-16)
163  (b @bad)
164  @8
165  (cmpwi cr0 imm2 ppc32::subtag-s8-vector)
166  (la imm3 3 imm3)
167  (srwi imm3 imm3 2)
168  (beq cr2 @char8)                      ; ppc32::max-8-bit-ivector-subtag
169  (beq cr0 @s8)
170  (extract-unsigned-byte-bits. imm0 val 8)
171  (unbox-fixnum imm0 val)
172  (beq+ cr0 @set-8)
173  (b @bad)
174  @s8
175  (slwi imm0 val (- 32 (+ 8 ppc32::fixnumshift)))
176  (srawi imm0 imm0 (- 32 (+ 8 ppc32::fixnumshift)))
177  (cmpw cr0 imm0 val)
178  (unbox-fixnum imm0 val)
179  (bne- cr7 @bad)
180  (beq+ cr0 @set-8)
181  (b @bad)
182  @char8
183  (unbox-base-char imm0 val cr0)   ; this type checks val
184  @set-8                                ; propagate low 8 bits into low 16
185  (rlwimi imm0 imm0 8 (- 32 16) (- 31 8))
186  @set-16                               ; propagate low 16 bits into high 16
187  (rlwimi imm0 imm0 16 0 (- 31 16))
188  @set-32
189  (cmpwi cr0 imm3 1)
190  (subi imm3 imm3 1)
191  (stwx imm0 miscobj imm4)
192  (la imm4 4 imm4)
193  (bne cr0 @set-32)
194  (blr))
195
196#+ppc64-target
197(defppclapfunction %init-misc ((val arg_y)
198                               (miscobj arg_z))
199  (getvheader imm0 miscobj)
200  ;(extract-lowtag imm2 imm0)
201  (clrldi imm2 imm0 (- 64 ppc64::nlowtagbits))
202  (header-size imm3 imm0)
203  (cmpdi cr3 imm3 0)
204  (extract-fulltag imm1 imm0)
205  (cmpdi cr0 imm2 ppc64::lowtag-nodeheader)
206  (extract-lowbyte imm2 imm0)
207  (beqlr cr3)                           ; Silly 0-length case
208  (li imm4 ppc64::misc-data-offset)
209  (bne cr0 @imm)
210  ;; Node vector.  Don't need to memoize, since initial value is
211  ;; older than vector.
212  @node-loop
213  (cmpdi cr0 imm3 1)
214  (subi imm3 imm3 1)
215  (stdx val miscobj imm4)
216  (la imm4 ppc64::node-size imm4)
217  (bne cr0 @node-loop)
218  (blr)
219  @imm
220  (extract-typecode imm0 val)           
221  (cmpdi cr0 imm1 ppc64::ivector-class-64-bit)
222  (cmpdi cr1 imm1 ppc64::ivector-class-32-bit)
223  (cmpdi cr2 imm1 ppc64::ivector-class-8-bit)
224  (cmpdi cr7 imm0 ppc64::tag-fixnum)
225  (cmpdi cr5 imm0 ppc64::subtag-bignum)
226  (beq cr0 @64)
227  (beq cr1 @32)
228  (beq cr2 @8)
229  ;; u16, s16, or bit-vector.  Val must be a fixnum.
230  (cmpdi cr0 imm2 ppc64::subtag-u16-vector)
231  (cmpdi cr1 imm2 ppc64::subtag-s16-vector)
232  (bne cr7 @bad)                        ; not a fixnum
233  (beq cr0 @u16)
234  (beq cr1 @s16)
235  ; Bit vector.
236  (cmpldi cr0 val '1)
237  (la imm3 63 imm3)
238  (srdi imm3 imm3 6)
239  (unbox-fixnum imm0 val)
240  (neg imm0 imm0)
241  (ble+ cr0 @set-64)
242  @bad
243  (li arg_x '#.$xnotelt)
244  (save-lisp-context)
245  (set-nargs 3)
246  (call-symbol %err-disp)
247  @64
248  (cmpdi cr3 imm2 ppc64::subtag-fixnum-vector)
249  (cmpdi cr1 imm2 ppc64::subtag-double-float-vector)
250  (cmpdi cr2 imm2 ppc64::subtag-s64-vector)
251  (beq cr3 @fixnum)
252  (beq cr1 @dfloat)
253  (bne cr2 @u64)
254  ;; s64
255  (unbox-fixnum imm0 val)
256  (beq cr7 @set-64)                     ; all fixnums are (SIGNED-BYTE 64)
257  (bne cr5 @bad)                        ; as are 2-digit bignums
258  (getvheader imm1 val)
259  (ld imm0 ppc64::misc-data-offset val)
260  (cmpdi imm1 ppc64::two-digit-bignum-header)
261  (rotldi imm0 imm0 32)
262  (beq @set-64)
263  (b @bad)
264@fixnum
265  (unbox-fixnum imm0 val)
266  (beq cr7 @set-64)                     ; all fixnums are (SIGNED-BYTE 64)
267  (b  @bad)                        ; as are 2-digit bignums
268   ;; u64 if fixnum and positive, 2-digit bignum and positive, or
269  ;; 3-digit bignum with most-significant digit 0.
270  @u64
271  (cmpdi cr2 val 0)
272  (unbox-fixnum imm0 val)
273  (bne cr7 @u64-maybe-bignum)
274  (bge cr2 @set-64)
275  (b @bad)
276  @u64-maybe-bignum
277  (bne cr5 @bad)
278  (ld imm0 ppc64::misc-data-offset val)
279  (getvheader imm1 val)
280  (rotldi imm0 imm0 32)
281  (cmpdi cr2 imm1 ppc64::two-digit-bignum-header)
282  (cmpdi cr3 imm1 ppc64::three-digit-bignum-header)
283  (cmpdi cr0 imm0 0)
284  (beq cr2 @u64-two-digit)
285  (bne cr3 @bad)
286  (lwz imm1 (+ 8 ppc64::misc-data-offset) val)
287  (cmpwi imm1 0)
288  (beq @set-64)
289  (b @bad)
290  @u64-two-digit
291  (bgt cr0 @set-64)
292  (b @bad)
293  @dfloat
294  (cmpdi cr0 imm0 ppc64::subtag-double-float)
295  (bne- cr0 @bad)
296  (ld imm0 ppc64::double-float.value val)
297  (b @set-64)
298  @32
299  (cmpdi cr3 imm2 ppc64::subtag-simple-base-string)
300  (cmpdi cr2 imm2 ppc64::subtag-s32-vector)
301  (cmpdi cr0 imm2 ppc64::subtag-single-float-vector)
302  (beq cr3 @char32)
303  (beq cr2 @s32)
304  (bne cr0 @u32)
305  ;@sfloat
306  (cmpdi cr0 imm0 ppc64::subtag-single-float)
307  (srdi imm0 val 32)
308  (bne- cr0 @bad)
309  (b @set-32)
310  @s32
311  ;; Must be a fixnum (and a (SIGNED-BYTE 32)).
312  (bne cr7 @bad)
313  (unbox-fixnum imm0 val)
314  (sldi imm1 imm0 32)
315  (sradi imm1 imm1 32)
316  (cmpd imm1 imm0)
317  (bne @bad)
318  (b @set-32)
319  @char32
320  (unbox-base-char imm0 val cr0)   ; this type checks val
321  (b @set-32)
322  @u32
323  ;; Also has to be a fixnum (and an (UNSIGNED-BYTE 32)).
324  (unbox-fixnum imm0 val)
325  (clrrdi. imm1 imm0 32)                ; ~Z if any high bits set
326  (bne cr7 @bad)
327  (bne cr0 @bad)
328  (b @set-32)
329  @u16
330  (unbox-fixnum imm0 val)
331  (clrrdi. imm1 imm0 16)
332  (bne cr7 @bad)
333  (bne cr0 @bad)
334  (b @set-16)
335  @s16
336  (sldi imm0 val (- 64 (+ 16 ppc64::fixnumshift)))
337  (sradi imm0 imm0 (- 64 (+ 16 ppc64::fixnumshift)))
338  (cmpw cr0 imm0 val)
339  (unbox-fixnum imm0 val)
340  (bne- cr7 @bad)
341  (beq+ cr0 @set-16)
342  (b @bad)
343  @8
344  (cmpdi cr0 imm2 ppc64::subtag-s8-vector)
345  (beq cr0 @s8)
346  (extract-unsigned-byte-bits. imm0 val 8)
347  (unbox-fixnum imm0 val)
348  (beq+ cr0 @set-8)
349  (b @bad)
350  @s8
351  (sldi imm0 val (- 64 (+ 8 ppc64::fixnumshift)))
352  (sradi imm0 imm0 (- 64 (+ 8 ppc64::fixnumshift)))
353  (cmpd cr0 imm0 val)
354  (unbox-fixnum imm0 val)
355  (bne- cr7 @bad)
356  (beq+ cr0 @set-8)
357  (b @bad)
358  @char8
359  (unbox-base-char imm0 val cr0)   ; this type checks val
360  @set-8                                ; propagate low 8 bits into low 16
361  (la imm3 1 imm3)
362  (rlwimi imm0 imm0 8 (- 32 16) (- 31 8))
363  (srdi imm3 imm3 1)
364  @set-16                               ; propagate low 16 bits into high 16
365  (la imm3 1 imm3)
366  (rlwimi imm0 imm0 16 0 (- 31 16))
367  (srdi imm3 imm3 1) 
368  @set-32                               ; propagate low 32 bits into high 32
369  (la imm3 1 imm3)
370  (rldimi imm0 imm0 32 0)
371  (srdi imm3 imm3 1)
372  @set-64
373  (cmpdi cr0 imm3 1)
374  (subi imm3 imm3 1)
375  (stdx imm0 miscobj imm4)
376  (la imm4 8 imm4)
377  (bne cr0 @set-64)
378  (blr))
379
380;;; Make a new vector of size newsize whose subtag matches that of oldv-arg.
381;;; Blast the contents of the old vector into the new one as quickly as
382;;; possible; leave remaining elements of new vector undefined (0).
383;;; Return new-vector.
384#+ppc32-target
385(defppclapfunction %extend-vector ((start-arg arg_x) (oldv-arg arg_y) (newsize arg_z))
386  (let ((oldv save0)
387        (oldsize save1)
388        (oldsubtag save2)
389        (start-offset save3))
390    (save-lisp-context)
391    (:regsave save3 0)
392    (vpush save0)
393    (vpush save1)
394    (vpush save2)
395    (vpush save3)
396    (mr oldv oldv-arg)
397    (mr start-offset start-arg)
398    (getvheader imm0 oldv)
399    (header-length oldsize imm0)
400    (header-subtag[fixnum] oldsubtag imm0)
401    (mr arg_y newsize)
402    (mr arg_z oldsubtag)
403    (bla .SPmisc-alloc)
404    (extrwi imm0 oldsubtag ppc32::ntagbits (- 32 (+  ppc32::fixnumshift ppc32::ntagbits)))
405    (cmpwi cr0 oldsize 0)
406    (cmpwi cr1 imm0 ppc32::fulltag-nodeheader)
407    (cmpwi cr2 oldsubtag '#.ppc32::max-32-bit-ivector-subtag)
408    (la imm1 ppc32::misc-data-offset start-offset)
409    (li imm3 ppc32::misc-data-offset)
410    (beq cr0 @done)
411    (bne cr1 @imm)
412    ;; copy nodes.  New vector is "new", so no memoization required.
413    @node-loop
414    (cmpwi cr0 oldsize '1)
415    (lwzx temp0 oldv imm1)
416    (addi imm1 imm1 4)
417    (subi oldsize oldsize '1)
418    (stwx temp0 arg_z imm3)
419    (addi imm3 imm3 4)
420    (bne cr0 @node-loop)
421    ;;Restore registers.  New vector's been in arg_z all this time.
422    @done
423    (lwz save3 0 vsp)
424    (lwz save2 4 vsp)
425    (lwz save1 8 vsp)
426    (lwz save0 12 vsp)
427    (restore-full-lisp-context)
428    (blr)
429    @imm
430    (unbox-fixnum imm2 oldsize)
431    (unbox-fixnum imm3 start-offset)
432    (li imm1 ppc32::misc-data-offset)
433    (la imm4 ppc32::misc-data-offset start-offset)
434    (cmpwi cr1 oldsubtag '#.ppc32::max-8-bit-ivector-subtag)
435    (cmpwi cr0 oldsubtag '#.ppc32::max-16-bit-ivector-subtag)
436    (ble cr2 @fullword-loop)
437    (cmpwi cr2 oldsubtag '#.ppc32::subtag-bit-vector)
438    (ble cr1 @8-bit)
439    (ble cr0 @16-bit)
440    (beq cr2 @1-bit)
441    ;; 64-bit (double-float) vectors.  There's a different
442    ;; initial offset, but we're always word-aligned, so that
443    ;; part's easy.
444    (li imm1 ppc32::misc-dfloat-offset)   ; scaled destination pointer
445    (slwi imm2 imm2 1)                  ; twice as many fullwords
446    (slwi imm3 imm3 3)                  ; convert dword count to byte offset
447    (la imm4 ppc32::misc-dfloat-offset imm3)      ; scaled source pointer
448    (b @fullword-loop)
449    ;; The bitvector case is hard if START-OFFSET isn't on an 8-bit boundary,
450    ;;  and can be turned into the 8-bit case otherwise.
451    ;; The 8-bit case is hard if START-OFFSET isn't on a 16-bit boundary,
452    ;;  and can be turned into the 16-bit case otherwise.
453    ;; The 16-bit case is hard if START-OFFSET isn't on a 32-bit boundary,
454    ;;  and can be turned into the 32-bit case otherwise.
455    ;; Hmm.
456    @1-bit
457    (clrlwi. imm0 imm3 (- 32 3))
458    (bne- cr0 @hard-1-bit)
459    (srwi imm3 imm3 3)                  ; bit offset to byte offset
460    (addi imm2 imm2 7)
461    (srwi imm2 imm2 3)                  ; bit count to byte count
462    @8-bit
463    ; If the byte offset's even, copy half as many halfwords
464    (clrlwi. imm0 imm3 (- 32 1))
465    (bne- cr0 @hard-8-bit)
466    (addi imm2 imm2 1)
467    (srwi imm2 imm2 1)                  ; byte count to halfword count
468    (srwi imm3 imm3 1)                  ; byte offset to halfword offset
469    @16-bit
470    ; If the halfword offset's even, copy half as many fullwords
471    (clrlwi. imm0 imm3 (- 32 1))
472    (bne- cr0 @hard-16-bit)
473    (addi imm2 imm2 1)
474    (srwi imm2 imm2 1)                  ; halfword count to fullword count
475    (li imm1 ppc32::misc-data-offset)   
476    @fullword-loop
477    (cmpwi cr0 imm2 1)
478    (lwzx imm0 oldv imm4)
479    (addi imm4 imm4 4)
480    (subi imm2 imm2 1)
481    (stwx imm0 arg_z imm1)
482    (addi imm1 imm1 4)
483    (bne cr0 @fullword-loop)
484    (b @done)
485    ;;; This can just do a uvref/uvset loop.  Cases that can
486    ;;; cons (x32, double-float) have already been dealt with.
487    @hard-1-bit
488    @hard-8-bit
489    @hard-16-bit
490    (let ((newv save4)
491          (outi save5)
492          (oldlen save6))
493      (vpush save4)
494      (vpush save5)
495      (vpush save6)
496      (mr newv arg_z)
497      (sub oldlen oldsize start-offset)
498      (li outi 0)
499      @hard-loop
500      (mr arg_y oldv)
501      (mr arg_z start-offset)
502      (bla .SPmisc-ref)
503      (mr arg_x newv)
504      (mr arg_y outi)
505      (bla .SPmisc-set)
506      (la outi '1 outi)
507      (cmpw cr0 outi oldlen)
508      (la start-offset '1 start-offset)
509      (bne @hard-loop)
510      (mr arg_z newv)
511      (vpop save6)
512      (vpop save5)
513      (vpop save4)
514      (b @done))))
515
516#+ppc64-target
517(defppclapfunction %extend-vector ((start-arg arg_x) (oldv-arg arg_y) (newsize arg_z))
518  (let ((oldv save0)
519        (oldsize save1)
520        (oldsubtag save2)
521        (start-offset save3))
522    (save-lisp-context)
523    (:regsave save3 0)
524    (vpush save0)
525    (vpush save1)
526    (vpush save2)
527    (vpush save3)
528    (mr oldv oldv-arg)
529    (mr start-offset start-arg)
530    (getvheader imm0 oldv)
531    (header-length oldsize imm0)
532    (header-subtag[fixnum] oldsubtag imm0)
533    (mr arg_y newsize)
534    (mr arg_z oldsubtag)
535    (bla .SPmisc-alloc)
536    (unbox-fixnum imm0 oldsubtag)
537    (extract-lowtag imm1 imm0)
538    (extract-fulltag imm2 imm0)
539    (cmpdi cr0 oldsize 0)
540    (cmpdi cr1 imm1 ppc64::lowtag-nodeheader)
541    (cmpdi cr2 imm2 ppc64::ivector-class-8-bit)
542    (cmpdi cr3 imm2 ppc64::ivector-class-32-bit)
543    (cmpdi cr4 imm2 ppc64::ivector-class-64-bit)
544    (cmpdi cr5 imm0 ppc64::subtag-bit-vector)
545    (li imm3 ppc64::misc-data-offset)
546    (beq cr0 @done)
547    (bne cr1 @imm)
548    (la imm1 ppc64::misc-data-offset start-offset)
549    ;; copy nodes.  New vector is "new", so no memoization required.
550    @node-loop
551    (cmpdi cr0 oldsize '1)
552    (ldx temp0 oldv imm1)
553    (addi imm1 imm1 8)
554    (subi oldsize oldsize '1)
555    (stdx temp0 arg_z imm3)
556    (addi imm3 imm3 8)
557    (bne cr0 @node-loop)
558    ;;Restore registers.  New vector's been in arg_z all this time.
559    @done
560    (ld save3 0 vsp)
561    (ld save2 8 vsp)
562    (ld save1 16 vsp)
563    (ld save0 24 vsp)
564    (restore-full-lisp-context)
565    (blr)
566    @imm
567    (beq cr2 @8-bit)
568    (beq cr3 @32-bit)
569    (beq cr4 @64-bit)
570    (beq cr5 @1-bit)
571    (srdi imm1 start-offset 2)
572    (la imm1 ppc64::misc-data-offset imm1)
573    @16-loop
574    (cmpdi cr0 oldsize '1)
575    (lhzx imm4 oldv imm1)
576    (addi imm1 imm1 2)
577    (subi oldsize oldsize '1)
578    (sthx imm4 arg_z imm3)
579    (addi imm3 imm3 2)
580    (bne cr0 @16-loop)
581    (b @done)
582    @8-bit
583    (srdi imm1 start-offset 3)
584    (la imm1 ppc64::misc-data-offset imm1)
585    @8-loop
586    (cmpdi cr0 oldsize '1)
587    (lbzx imm4 oldv imm1)
588    (addi imm1 imm1 1)
589    (subi oldsize oldsize '1)
590    (stbx imm4 arg_z imm3)
591    (addi imm3 imm3 1)
592    (bne cr0 @8-loop)
593    (b @done)
594    @32-bit
595    (srdi imm1 start-offset 1)
596    (la imm1 ppc64::misc-data-offset imm1)
597    @32-loop
598    (cmpdi cr0 oldsize '1)
599    (lwzx imm4 oldv imm1)
600    (addi imm1 imm1 4)
601    (subi oldsize oldsize '1)
602    (stwx imm4 arg_z imm3)
603    (addi imm3 imm3 4)
604    (bne cr0 @32-loop)
605    (b @done)
606    @64-bit
607    (la imm1 ppc64::misc-data-offset start-offset)
608    @64-loop
609    (cmpdi cr0 oldsize '1)
610    (ldx imm4 oldv imm1)
611    (addi imm1 imm1 8)
612    (subi oldsize oldsize '1)
613    (stdx imm4 arg_z imm3)
614    (addi imm3 imm3 8)
615    (bne cr0 @64-loop)
616    (b @done)
617    @1-bit
618    (let ((newv save4)
619          (outi save5)
620          (oldlen save6))
621      (vpush save4)
622      (vpush save5)
623      (vpush save6)
624      (mr newv arg_z)
625      (sub oldlen oldsize start-offset)
626      (li outi 0)
627      @hard-loop
628      (mr arg_y oldv)
629      (mr arg_z start-offset)
630      (bla .SPmisc-ref)
631      (mr arg_x newv)
632      (mr arg_y outi)
633      (bla .SPmisc-set)
634      (la outi '1 outi)
635      (cmpd cr0 outi oldlen)
636      (la start-offset '1 start-offset)
637      (bne @hard-loop)
638      (mr arg_z newv)
639      (vpop save6)
640      (vpop save5)
641      (vpop save4)
642      (b @done))))
643
644
645;;; argument is a vector header or an array header.  Or else.
646(defppclapfunction %array-header-data-and-offset ((a arg_z))
647  (let ((offset arg_y)
648        (disp arg_x)
649        (temp temp0))
650    (li offset 0)
651    (mr temp a)
652    @loop
653    (ldr a target::arrayH.data-vector temp)
654    (lbz imm0 target::misc-subtag-offset a)
655    (cmpri cr0 imm0 target::subtag-vectorH)
656    (ldr disp target::arrayH.displacement temp)
657    (mr temp a)
658    (add offset offset disp)
659    (ble cr0 @loop)
660    (vpush a)
661    (vpush offset)
662    (set-nargs 2)
663    (la temp0 (* 2 (ash 1 target::word-shift)) vsp)
664    (ba .SPvalues)))
665
666
667;;; If the bit-arrays are all simple-bit-vectorp, we can do the operations
668;;; 32 bits at a time.  (other case have to worry about alignment/displacement.)
669#+ppc32-target
670(defppclapfunction %simple-bit-boole ((op 0) (b1 arg_x) (b2 arg_y) (result arg_z))
671  (la imm0 4 vsp)
672  (save-lisp-context imm0)
673  (vector-size imm4 result imm4)
674  (srwi. imm3 imm4 5)
675  (clrlwi imm4 imm4 27)
676  (bl @get-dispatch)
677  (cmpwi cr1 imm4 0)
678  (mflr loc-pc)
679  (lwz temp0 op vsp)
680  (add loc-pc loc-pc temp0)
681  (add loc-pc loc-pc temp0)
682  (mtctr loc-pc)
683  (li imm0 ppc32::misc-data-offset)
684  (b @testw)
685  @nextw
686  (cmpwi cr0 imm3 1)
687  (subi imm3 imm3 1)
688  (lwzx imm1 b1 imm0)
689  (lwzx imm2 b2 imm0)
690  (bctrl)
691  (stwx imm1 result imm0)
692  (addi imm0 imm0 4)
693  @testw
694  (bne cr0 @nextw)
695  (beq cr1 @done)
696  ;; Not sure if we need to make this much fuss about the partial word
697  ;; in this simple case, but what the hell.
698  (lwzx imm1 b1 imm0)
699  (lwzx imm2 b2 imm0)
700  (bctrl)
701  (lwzx imm2 result imm0)
702  (slw imm2 imm2 imm4)
703  (srw imm2 imm2 imm4)
704  (subfic imm4 imm4 32)
705  (srw imm1 imm1 imm4)
706  (slw imm1 imm1 imm4)
707  (or imm1 imm1 imm2)
708  (stwx imm1 result imm0)
709  @done
710  (restore-full-lisp-context)
711  (blr)
712
713  @get-dispatch 
714  (blrl)
715  @disptach
716  (li imm1 0)                           ; boole-clr
717  (blr)
718  (li imm1 -1)                          ; boole-set
719  (blr)
720  (blr)                                 ; boole-1
721  (blr)                             
722  (mr imm1 imm2)                        ; boole-2
723  (blr)
724  (not imm1 imm1)                       ; boole-c1
725  (blr)
726  (not imm1 imm2)                       ; boole-c2
727  (blr)
728  (and imm1 imm1 imm2)                  ; boole-and
729  (blr)
730  (or imm1 imm1 imm2)                   ; boole-ior
731  (blr)
732  (xor imm1 imm1 imm2)                  ; boole-xor
733  (blr)
734  (eqv imm1 imm1 imm2)                  ; boole-eqv
735  (blr)
736  (nand imm1 imm1 imm2)                 ; boole-nand
737  (blr)
738  (nor imm1 imm1 imm2)                  ; boole-nor
739  (blr)
740  (andc imm1 imm2 imm1)                 ; boole-andc1
741  (blr)
742  (andc imm1 imm1 imm2)                 ; boole-andc2
743  (blr)
744  (orc imm1 imm2 imm1)                  ; boole-orc1
745  (blr)
746  (orc imm1 imm1 imm2)                  ; boole-orc2
747  (blr))
748
749#+ppc64-target
750(defppclapfunction %simple-bit-boole ((op 0) (b1 arg_x) (b2 arg_y) (result arg_z))
751  (la imm0 8 vsp)
752  (save-lisp-context imm0)
753  (vector-size imm4 result imm4)
754  (srdi. imm3 imm4 6)
755  (clrldi imm4 imm4 (- 64 6))
756  (bl @get-dispatch)
757  (cmpdi cr1 imm4 0)                    ; at most low 6 bits set in imm4
758  (mflr loc-pc)
759  (ld temp0 op vsp)
760  (add loc-pc loc-pc temp0)
761  (mtctr loc-pc)
762  (li imm0 ppc64::misc-data-offset)
763  (b @testd)
764  @nextd
765  (cmpdi cr0 imm3 1)
766  (subi imm3 imm3 1)
767  (ldx imm1 b1 imm0)
768  (ldx imm2 b2 imm0)
769  (bctrl)
770  (stdx imm1 result imm0)
771  (addi imm0 imm0 8)
772  @testd
773  (bne cr0 @nextd)
774  (beq cr1 @done)
775  ;; Not sure if we need to make this much fuss about the partial word
776  ;; in this simple case, but what the hell.
777  (ldx imm1 b1 imm0)
778  (ldx imm2 b2 imm0)
779  (bctrl)
780  (ldx imm2 result imm0)
781  (sld imm2 imm2 imm4)
782  (srd imm2 imm2 imm4)
783  (subfic imm4 imm4 64)
784  (srd imm1 imm1 imm4)
785  (sld imm1 imm1 imm4)
786  (or imm1 imm1 imm2)
787  (stdx imm1 result imm0)
788  @done
789  (restore-full-lisp-context)
790  (blr)
791
792  @get-dispatch 
793  (blrl)
794  @disptach
795  (li imm1 0)                           ; boole-clr
796  (blr)
797  (li imm1 -1)                          ; boole-set
798  (blr)
799  (blr)                                 ; boole-1
800  (blr)                             
801  (mr imm1 imm2)                        ; boole-2
802  (blr)
803  (not imm1 imm1)                       ; boole-c1
804  (blr)
805  (not imm1 imm2)                       ; boole-c2
806  (blr)
807  (and imm1 imm1 imm2)                  ; boole-and
808  (blr)
809  (or imm1 imm1 imm2)                   ; boole-ior
810  (blr)
811  (xor imm1 imm1 imm2)                  ; boole-xor
812  (blr)
813  (eqv imm1 imm1 imm2)                  ; boole-eqv
814  (blr)
815  (nand imm1 imm1 imm2)                 ; boole-nand
816  (blr)
817  (nor imm1 imm1 imm2)                  ; boole-nor
818  (blr)
819  (andc imm1 imm2 imm1)                 ; boole-andc1
820  (blr)
821  (andc imm1 imm1 imm2)                 ; boole-andc2
822  (blr)
823  (orc imm1 imm2 imm1)                  ; boole-orc1
824  (blr)
825  (orc imm1 imm1 imm2)                  ; boole-orc2
826  (blr))
827
828
829(defppclapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z))
830  (check-nargs 3)
831  (ba .SParef2))
832
833(defppclapfunction %aref3 ((array 0) (i arg_x) (j arg_y) (k arg_z))
834  (check-nargs 4)
835  (vpop temp0)
836  (ba .SParef3))
837
838
839(defppclapfunction %aset2 ((array 0) (i arg_x) (j arg_y) (newval arg_z))
840  (check-nargs 4)
841  (vpop temp0)
842  (ba .SPaset2))
843
844(defppclapfunction %aset3 ((array #.target::node-size) (i 0) (j arg_x) (k arg_y)  (newval arg_z))
845  (check-nargs 5)
846  (vpop temp0)
847  (vpop temp1)
848  (ba .SPaset3))
849 
850
Note: See TracBrowser for help on using the repository browser.