source: branches/arm/level-0/ARM/arm-pred.lisp @ 13852

Last change on this file since 13852 was 13852, checked in by gb, 9 years ago

EQUAL: call what's in HAIRY-EQUAL's function (not value) cell.

File size: 4.8 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL 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 "ARM-LAPMACROS"))
21
22(defarmlapfunction eql ((x arg_y) (y arg_z))
23  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
24  (check-nargs 2)
25  @tail
26  (cmp x y)
27  (extract-lisptag imm0 x)
28  (extract-lisptag imm1 y)
29  (beq @win)
30  (cmp imm0 (:$ arm::tag-misc))
31  (cmpeq imm1 (:$ arm::tag-misc))
32  (bne @lose)
33  ;; Objects are both of tag-misc.  Headers must match exactly;
34  ;; dispatch on subtag.
35  (getvheader imm1 y)
36  (extract-lowbyte imm2 imm1)
37  (getvheader imm0 x)
38  (cmp imm2 (:$ arm::subtag-macptr))
39  (beq @macptr)
40  (cmp imm0 imm1)
41  (bne @lose)
42  (cmp imm2 (:$ arm::max-numeric-subtag))
43  (bgt @lose)
44  (cmp imm2 (:$ arm::subtag-ratio))
45  (cmpne imm2 (:$ arm::subtag-complex))
46  (beq @node)
47  (cmp imm2 (:$ arm::subtag-bignum))
48  (beq @bignum)
49  (cmp imm2 (:$ arm::subtag-double-float))
50  (bne @one-unboxed-word)
51  ;; This is the double-float case.
52  (ldr imm0 (:@ x (:$ arm::double-float.value)))
53  (ldr imm1 (:@ y (:$ arm::double-float.value)))
54  (cmp imm0 imm1)
55  (ldreq imm0 (:@ x (:$ arm::double-float.val-low)))
56  (ldreq imm1 (:@ y (:$ arm::double-float.val-low)))
57  (cmpeq imm0 imm1)
58  (mov arg_z 'nil)
59  (addeq arg_z arg_z (:$ arm::t-offset))
60  (bx lr)
61  @win
62  (mov arg_z 'nil)
63  (add arg_z arg_z ($ arm::t-offset))
64  (bx lr)
65  @macptr
66  (extract-lowbyte imm0 imm0)
67  (cmp imm2 imm0)
68  (bne @lose)
69  @one-unboxed-word
70  (ldr imm0 (:@ x (:$ arm::misc-data-offset)))
71  (ldr imm1 (:@ y (:$ arm::misc-data-offset)))
72  (cmp imm0 imm1)
73  (beq  @win)
74  @lose
75  (mov arg_z 'nil)
76  (bx lr)
77  @bignum
78  ;; Way back when, we got x's header into imm0.  We know that y's
79  ;; header is identical.  Use the element-count from imm0 to control
80  ;; the loop.  There's no such thing as a 0-element bignum, so the
81  ;; loop must always execute at least once.
82  (header-length temp0 imm0)
83  (mov imm2 (:$ arm::misc-data-offset))
84  @bignum-next
85  (ldr imm0 (:@ x imm2))
86  (ldr imm1 (:@ y imm2))
87  (cmp imm0 imm1)
88  (add imm2 imm2 (:$ arm::node-size))
89  (bne @lose)
90  (subs temp0 temp0 '1)
91  (bne @bignum-next)
92  (mov arg_z 'nil)
93  (add arg_z arg_z (:$ arm::t-offset))
94  (bx lr)
95  @node
96  ;; Have either a ratio or a complex.  In either case, corresponding
97  ;; elements of both objects must be EQL.  Recurse on the first
98  ;; elements.  If true, tail-call on the second, else fail.
99  (vpush1 x)
100  (vpush1 y)
101  (build-lisp-frame imm0)
102  (ldr x (:@ x (:$ arm::misc-data-offset)))
103  (ldr y (:@ y (:$ arm::misc-data-offset)))
104  (bl @tail)
105  (cmp arg_z 'nil)
106  (restore-lisp-frame imm0)
107  (vpop1 y)
108  (vpop1 x)
109  (beq @lose)
110  (ldr x (:@ x (:$ (+ 4 arm::misc-data-offset))))
111  (ldr y (:@ y (:$ (+ 4 arm::misc-data-offset))))
112  (b @tail))
113
114
115 
116
117(defarmlapfunction equal ((x arg_y) (y arg_z))
118  "Return T if X and Y are EQL or if they are structured components
119  whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
120  are the same length and have identical components. Other arrays must be
121  EQ to be EQUAL.  Pathnames are EQUAL if their components are."
122  (check-nargs 2)
123  @top
124  (cmp x y)
125  (extract-fulltag imm0 x)
126  (extract-fulltag imm1 y)
127  (beq @win)
128  (cmp imm0 imm1)
129  (bne @lose)
130  (cmp imm0 (:$ arm::fulltag-cons))
131  (beq @cons)
132  (cmp imm0 (:$ arm::fulltag-misc))
133  (beq @misc)
134  @lose
135  (mov arg_z 'nil)
136  (bx lr)
137  @win
138  (mov arg_z 'nil)
139  (add arg_z arg_z (:$ arm::t-offset))
140  (bx lr)
141  @cons
142  (%car temp0 x)
143  (%car temp1 y)
144  (cmp temp0 temp1)
145  (bne @recurse)
146  (%cdr x x)
147  (%cdr y y)
148  (b @top)
149  @recurse
150  (vpush1 x)
151  (vpush1 y)
152  (build-lisp-frame imm0)
153  (mov x temp0)
154  (mov y temp1)
155  (bl @top)
156  (cmp arg_z 'nul) 
157  (mov nfn fn)
158  (restore-lisp-frame imm0)           ; gets old fn to fn 
159  (vpop1 y)
160  (vpop1 x)
161  (beq  @lose)
162  (%cdr x x)
163  (%cdr y y)
164  (b @top)
165  @misc
166  (extract-subtag imm0 x)
167  (extract-subtag imm1 y)
168  (cmp imm0 (:$ arm::subtag-vectorH))
169  (cmpne imm1 (:$ arm::subtag-vectorH))
170  (beq @hairy)
171  (cmp imm0 (:$ arm::subtag-macptr))
172  (bgt @same)
173  (ldr fname (:@ nfn 'eql))
174  (ldr nfn (:@ fname (:$ arm::symbol.vcell)))
175  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
176  @same
177  (cmp imm1 imm0)
178  (bne @lose)
179  @hairy
180  (ldr fname (:@ nfn 'hairy-equal))
181  (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
182  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
Note: See TracBrowser for help on using the repository browser.