source: trunk/ccl/level-0/PPC/ppc-pred.lisp @ 3062

Last change on this file since 3062 was 3062, checked in by gb, 14 years ago

Try to bum the 32-bit EQUAL a bit.
The ppc64 version needs work, too.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.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(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (require "PPC-LAPMACROS"))
21
22#+ppc32-target
23(defppclapfunction eql ((x arg_y) (y arg_z))
24  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
25  (check-nargs 2)
26  @tail
27  (cmpw cr0 x y)
28  (extract-lisptag imm0 x)
29  (extract-lisptag imm1 y)
30  (cmpwi cr1 imm0 ppc32::tag-misc)
31  (cmpwi cr2 imm1 ppc32::tag-misc)
32  (beq cr0 @win)
33  (bne cr1 @lose)
34  (bne cr2 @lose)
35  ;; Objects are both of tag-misc.  Headers must match exactly;
36  ;; dispatch on subtag.
37  (getvheader imm0 x)
38  (getvheader imm1 y)
39  (cmpw cr0 imm0 imm1)
40  (extract-lowbyte imm1 imm1)
41  (cmpwi cr1 imm1 ppc32::subtag-macptr)
42  (cmpwi cr2 imm1 ppc32::max-numeric-subtag)
43  (beq cr1 @macptr)
44  (bne cr0 @lose)
45  (bgt cr2 @lose)
46  (cmpwi cr0 imm1 ppc32::subtag-ratio)
47  (cmpwi cr1 imm1 ppc32::subtag-complex)
48  (beq cr0 @node)
49  (beq cr1 @node)
50  ; A single-float looks a lot like a macptr to me.
51  ; A double-float is simple, a bignum involves a loop.
52  (cmpwi cr0 imm1 ppc32::subtag-bignum)
53  (cmpwi cr1 imm1 ppc32::subtag-double-float)
54  (beq cr0 @bignum)
55  (bne cr1 @one-unboxed-word)                     ; single-float case
56  ; This is the double-float case.
57  (lwz imm0 ppc32::double-float.value x)
58  (lwz imm1 ppc32::double-float.value y)
59  (cmpw cr0 imm0 imm1)
60  (lwz imm0 ppc32::double-float.val-low x)
61  (lwz imm1 ppc32::double-float.val-low y)
62  (cmpw cr1 imm0 imm1)
63  (bne cr0 @lose)
64  (bne cr1 @lose)
65  @win
66  (li arg_z (+ ppc32::t-offset ppc32::nil-value))
67  (blr)
68  @macptr
69  (extract-lowbyte imm0 imm0)
70  (cmpw cr0 imm1 imm0)
71  (bne- cr0 @lose)
72  @one-unboxed-word
73  (lwz imm0 ppc32::misc-data-offset x)
74  (lwz imm1 ppc32::misc-data-offset y)
75  (cmpw cr0 imm0 imm1)
76  (beq cr0 @win)
77  @lose
78  (li arg_z ppc32::nil-value)
79  (blr)
80  @bignum
81  ;; Way back when, we got x's header into imm0.  We know that y's
82  ;; header is identical.  Use the element-count from imm0 to control
83  ;; the loop.  There's no such thing as a 0-element bignum, so the
84  ;; loop must always execute at least once.
85  (header-size imm0 imm0)
86  (li imm1 ppc32::misc-data-offset)
87  @bignum-next
88  (cmpwi cr1 imm0 1)                    ; last time through ?
89  (lwzx imm2 x imm1)
90  (lwzx imm3 y imm1)
91  (cmpw cr0 imm2 imm3)
92  (subi imm0 imm0 1)
93  (la imm1 4 imm1)
94  (bne cr0 @lose)
95  (bne cr1 @bignum-next)
96  (li arg_z (+ ppc32::t-offset ppc32::nil-value))
97  (blr)
98  @node
99  ;; Have either a ratio or a complex.  In either case, corresponding
100  ;; elements of both objects must be EQL.  Recurse on the first
101  ;; elements.  If true, tail-call on the second, else fail.
102  (vpush x)
103  (vpush y)
104  (save-lisp-context)
105  (lwz x ppc32::misc-data-offset x)
106  (lwz y ppc32::misc-data-offset y)
107  (bl @tail)
108  (cmpwi cr0 arg_z ppc32::nil-value)
109  (restore-full-lisp-context)
110  (vpop y)
111  (vpop x)
112  (beq cr0 @lose)
113  (lwz x (+ 4 ppc32::misc-data-offset) x)
114  (lwz y (+ 4 ppc32::misc-data-offset) y)
115  (b @tail))
116
117#+ppc64-target
118(defppclapfunction eql ((x arg_y) (y arg_z))
119  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
120  (check-nargs 2)
121  @tail
122  (cmpd cr0 x y)
123  (extract-fulltag imm0 x)
124  (extract-fulltag imm1 y)
125  (cmpri cr1 imm0 ppc64::fulltag-misc)
126  (cmpri cr2 imm1 ppc64::fulltag-misc)
127  (beq cr0 @win)
128  (bne cr1 @lose)
129  (bne cr2 @lose)
130  ;; Objects are both of tag-misc.  Headers must match exactly;
131  ;; dispatch on subtag.
132  (getvheader imm0 x)
133  (getvheader imm1 y)
134  (cmpd cr0 imm0 imm1)
135  (extract-lowbyte imm1 imm1)
136  (cmpdi cr1 imm1 ppc64::subtag-macptr)
137  (cmpdi cr2 imm1 ppc64::subtag-bignum)
138  (cmpdi cr3 imm1 ppc64::subtag-double-float)
139  (beq cr1 @macptr)
140  (cmpdi cr4 imm1 ppc64::subtag-complex)
141  (cmpdi cr5 imm1 ppc64::subtag-ratio)
142  (bne cr0 @lose)
143  (beq cr2 @bignum)
144  (beq cr3 @double-float)
145  (beq cr4 @complex)
146  (beq cr5 @ratio)
147  @lose
148  (li arg_z nil)
149  (blr)
150  @double-float
151  (ld imm0 ppc64::double-float.value x)
152  (ld imm1 ppc64::double-float.value y)
153  @test 
154  (cmpd imm0 imm1)
155  (bne @lose)
156  @win
157  (li arg_z (+ ppc64::nil-value ppc64::t-offset))
158  (blr)
159  ;; Macptr objects can have different lengths, but their subtags must
160  ;; match
161  @macptr
162  (extract-lowbyte imm0 imm0)
163  (cmpd imm0 imm1)
164  (bne @lose)
165  (ld imm0 ppc64::macptr.address x)
166  (ld imm1 ppc64::macptr.address y)
167  (b @test)
168  @ratio
169  @complex
170  (vpush x)
171  (vpush y)
172  (save-lisp-context)
173  (ld x ppc64::ratio.numer x)       ; aka complex.realpart
174  (ld y ppc64::ratio.numer y)       ; aka complex.imagpart
175  (bl @tail)
176  (cmpdi cr0 arg_z nil)
177  (restore-full-lisp-context)
178  (vpop y)
179  (vpop x)
180  (beq cr0 @lose)
181  (ld x ppc64::ratio.denom x)
182  (ld y ppc64::ratio.denom y)
183  (b @tail)
184  @bignum
185  ;; Way back when, we got x's header into imm0.  We know that y's
186  ;; header is identical.  Use the element-count from imm0 to control
187  ;; the loop.  There's no such thing as a 0-element bignum, so the
188  ;; loop must always execute at least once.
189  (header-size imm0 imm0)
190  (li imm1 ppc64::misc-data-offset)
191  @bignum-next
192  (cmpwi cr1 imm0 1)                    ; last time through ?
193  (lwzx imm2 x imm1)
194  (lwzx imm3 y imm1)
195  (cmpw cr0 imm2 imm3)
196  (subi imm0 imm0 1)
197  (la imm1 4 imm1)
198  (bne cr0 @lose)
199  (bne cr1 @bignum-next)
200  (li arg_z t)
201  (blr))
202 
203
204#+ppc32-target
205(defppclapfunction equal ((x arg_y) (y arg_z))
206  "Return T if X and Y are EQL or if they are structured components
207  whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
208  are the same length and have identical components. Other arrays must be
209  EQ to be EQUAL.  Pathnames are EQUAL if their components are."
210  (check-nargs 2)
211  @top
212  (cmpw cr0 x y)
213  (extract-fulltag imm0 x)
214  (extract-fulltag imm1 y)
215  (cmpw cr1 imm0 imm1)
216  (cmpwi cr2 imm0 ppc32::fulltag-cons)
217  (cmpwi cr3 imm0 ppc32::fulltag-misc)
218  (beq cr0 @win)
219  (bne cr1 @lose)
220  (beq cr2 @cons)
221  (bne cr3 @lose)
222  (extract-subtag imm0 x)
223  (extract-subtag imm1 y)
224  (cmpwi cr0 imm0 ppc32::subtag-macptr)
225  (cmpwi cr2 imm0 ppc32::subtag-istruct)
226  (cmpwi cr1 imm0 ppc32::subtag-vectorH)
227  (cmpw cr3 imm0 imm1)
228  (ble cr0 @eql)
229  (cmplwi cr0 imm1 ppc32::subtag-vectorH)
230  (beq cr2 @same)
231  (blt cr1 @lose)
232  (bge cr0 @go)
233  @lose
234  (li arg_z ppc32::nil-value)
235  (blr)
236  @same
237  (bne cr3 @lose)
238  @go
239  (set-nargs 2)
240  (lwz fname 'hairy-equal nfn)
241  (ba .SPjmpsym)
242  @eql
243  (set-nargs 2)
244  (lwz fname 'eql nfn)
245  (ba .SPjmpsym)
246  @cons
247  (%car temp0 x)
248  (%car temp1 y)
249  (cmpw temp0 temp1)
250  (bne @recurse)
251  (%cdr x x)
252  (%cdr y y)
253  (b @top)
254  @recurse
255  (vpush x)
256  (vpush y)
257  (save-lisp-context)
258  (lwz imm0 ppc32::tcr.cs-limit ppc32::rcontext) ; stack probe
259  (twllt ppc32::sp imm0)
260  (mr x temp0)
261  (mr y temp1)
262  (bl @top)
263  (cmpwi :cr0 arg_z ppc32::nil-value) 
264  (mr nfn fn)
265  (restore-full-lisp-context)           ; gets old fn to fn 
266  (vpop y)
267  (vpop x)
268  (beq cr0 @lose)
269  (%cdr x x)
270  (%cdr y y)
271  (b @top)
272  @win
273  (li arg_z (+ ppc32::t-offset ppc32::nil-value))
274  (blr))
275
276#+ppc64-target
277(defppclapfunction equal ((x arg_y) (y arg_z))
278  "Return T if X and Y are EQL or if they are structured components
279  whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
280  are the same length and have identical components. Other arrays must be
281  EQ to be EQUAL.  Pathnames are EQUAL if their components are."
282  (check-nargs 2)
283  @top
284  (cmpd cr0 x y)
285  (extract-fulltag imm0 x)
286  (extract-fulltag imm1 y)
287  (cmpd cr1 imm0 imm1)
288  (cmpdi cr2 imm0 ppc64::fulltag-cons)
289  (cmpdi cr3 imm0 ppc64::fulltag-misc)
290  (beq cr0 @win)
291  (bne cr1 @lose)
292  (beq cr2 @cons)
293  (beq cr3 @misc)
294  @lose
295  (li arg_z nil)
296  (blr)
297  @win
298  (li arg_z (+ ppc64::nil-value ppc64::t-offset))
299  (blr)
300  @cons
301  ;; Check to see if the CARs are EQ.  If so, we can avoid saving
302  ;; context, and can just tail call ourselves on the CDRs.
303  (%car temp0 x)
304  (%car temp1 y)
305  (cmpd temp0 temp1)
306  (bne @recurse)
307  (%cdr x x)
308  (%cdr y y)
309  (b @top)
310  @recurse
311  (vpush x)
312  (vpush y)
313  (save-lisp-context)
314  (ld imm0 ppc64::tcr.cs-limit ppc64::rcontext) ; stack probe
315  (tdllt ppc32::sp imm0)
316  (mr x temp0)
317  (mr y temp1)
318  (bl @top)
319  (cmpdi :cr0 arg_z nil) 
320  (mr nfn fn)
321  (restore-full-lisp-context)           ; gets old fn to fn 
322  (vpop y)
323  (vpop x)
324  (beq cr0 @lose)
325  (%cdr x x)
326  (%cdr y y)
327  (b @top)
328  @misc
329  ;; Both objects are uvectors of some sort.  Try EQL; if that fails,
330  ;; call HAIRY-EQUAL.
331  (vpush x)
332  (vpush y)
333  (save-lisp-context)
334  (set-nargs 2)
335  (ld fname 'eql nfn)
336  (set-nargs 2)
337  (bla .SPjmpsym)
338  (cmpdi arg_z nil)
339  (mr nfn fn)
340  (restore-full-lisp-context)
341  (vpop y)
342  (vpop x)
343  (bne @win)
344  (set-nargs 2)
345  (ld fname 'hairy-equal nfn)
346  (ba .SPjmpsym))
347
348
349
350     
351
352
353
354
355
356
357
Note: See TracBrowser for help on using the repository browser.