source: trunk/source/level-0/ARM/arm-clos.lisp @ 15601

Last change on this file since 15601 was 15093, checked in by gb, 8 years ago

New Linux ARM binaries.

The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.

(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.

Most of the changes are ARM-specific.

Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:

(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))

and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.

ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforward
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.

Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.

Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.

Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.

I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)

Fix ticket:894

Fixed a few typos in error messages/comments/etc.

I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)

File size: 8.5 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;;; It's easier to keep this is LAP; we want to play around with its
21;;; constants.
22
23;;; This just maps a SLOT-ID to a SLOT-DEFINITION or NIL.
24;;; The map is a vector of (UNSIGNED-BYTE 8); this should
25;;; be used when there are less than 255 slots in the class.
26(defarmlapfunction %small-map-slot-id-lookup ((slot-id arg_z))
27  (ldr temp1 (:@ nfn 'map))
28  (svref arg_x slot-id.index slot-id)
29  (getvheader imm0 temp1)
30  (header-length imm1 imm0)
31  (ldr temp0 (:@ nfn 'table))
32  (cmp arg_x imm1)
33  (mov imm0 (:lsr arg_x (:$ arm::word-shift)))
34  (add imm0 imm0 (:$ arm::misc-data-offset))
35  (mov imm1 (:$ arm::misc-data-offset))
36  (ldrblo imm1 (:@ temp1 imm0))
37  (movlo imm1 (:lsl imm1 (:$ arm::word-shift)))
38  (addlo imm1 imm1 (:$ arm::misc-data-offset))
39  (ldr arg_z (:@ temp0 imm1))
40  (bx lr))
41
42;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32).
43(defarmlapfunction %large-map-slot-id-lookup ((slot-id arg_z))
44  (ldr temp1 (:@ nfn 'map))
45  (svref arg_x slot-id.index slot-id)
46  (getvheader imm0 temp1)
47  (header-length imm1 imm0)
48  (ldr temp0 (:@ nfn 'table))
49  (cmp arg_x imm1)
50  (add imm0 arg_x (:$ arm::misc-data-offset))
51  (mov imm1 (:$ arm::misc-data-offset))
52  (ldrlo imm1 (:@ temp1 imm0))
53  (addlo imm1 imm1 (:$ arm::misc-data-offset))
54  (ldr arg_z (:@ temp0 imm1))
55  (bx lr))
56
57(defarmlapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z))
58  (ldr temp1 (:@ nfn 'map))
59  (svref arg_x slot-id.index slot-id)
60  (getvheader imm0 temp1)
61  (ldr temp0 (:@ nfn 'table))
62  (header-length imm1 imm0)
63  (cmp arg_x imm1)
64  (mov imm0 (:lsr arg_x (:$ arm::word-shift)))
65  (add imm0 imm0 (:$ arm::misc-data-offset))
66  (bhs @missing)
67  (ldrb imm1 (:@ temp1 imm0))
68  (cmp imm1 (:$ 0))
69  (mov imm1 (:lsl imm1 (:$ arm::word-shift)))
70  (add imm1 imm1 (:$ arm::misc-data-offset))
71  (beq @missing)
72  (ldr arg_z (:@ temp0 imm1))
73  (ldr arg_x (:@ nfn 'class))
74  (ldr nfn (:@ nfn '%maybe-std-slot-value))
75  (set-nargs 3)
76  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
77  @missing                              ; (%slot-id-ref-missing instance id)
78  (ldr nfn (:@ nfn '%slot-id-ref-missing))
79  (set-nargs 2)
80  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
81
82(defarmlapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z))
83  (ldr temp1 (:@ nfn 'map))
84  (svref arg_x slot-id.index slot-id)
85  (getvheader imm0 temp1)
86  (ldr temp0 (:@ nfn 'table))
87  (header-length imm1 imm0)
88  (cmp arg_x imm1)
89  (movhs arg_x (:$ 0))
90  (add imm0 arg_x (:$ arm::misc-data-offset))
91  (ldr imm1 (:@ temp1 imm0))
92  (movs imm1 (:lsl imm1 (:$ arm::fixnumshift)))
93  (add imm1 imm1 (:$ arm::misc-data-offset))
94  @have-scaled-table-index
95  (ldrne arg_x (:@ nfn 'class))
96  (ldrne nfn (:@ nfn '%maybe-std-slot-value-using-class))
97  (ldrne arg_z (:@ temp0 imm1))
98  (set-nargs 3)
99  (ldrne pc (:@ nfn (:$ arm::function.entrypoint)))
100  @missing                              ; (%slot-id-ref-missing instance id)
101  (ldr nfn (:@ nfn '%slot-id-ref-missing))
102  (set-nargs 2)
103  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
104
105
106(defarmlapfunction %small-set-slot-id-value ((instance arg_x)
107                                             (slot-id arg_y)
108                                             (new-value arg_z))
109  (ldr temp1 (:@ nfn 'map))
110  (svref temp0 slot-id.index slot-id)
111  (getvheader imm0 temp1)
112  (header-length imm1 imm0)
113  (cmp temp0 imm1)
114  (mov imm0 (:lsr temp0 (:$ arm::word-shift)))
115  (ldr temp0 (:@ nfn 'table))
116  (add imm0 imm0 (:$ arm::misc-data-offset))
117  (bhs @missing)
118  (ldrb imm1 (:@ temp1 imm0))
119  (cmp imm1 (:$ 0))
120  (mov imm1 (:lsl imm1 (:$ arm::word-shift)))
121  (add imm1 imm1 (:$ arm::misc-data-offset))
122  (beq @missing)
123  @have-scaled-table-index
124  (ldr temp1 (:@ nfn 'class))
125  (ldr arg_y (:@ temp0 imm1))
126  (ldr nfn (:@ nfn '%maybe-std-setf-slot-value-using-class))
127  (set-nargs 4)
128  (vpush1 temp1)
129  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
130  @missing                              ; (%slot-id-set-missing instance id new-value)
131  (ldr nfn (:@ nfn '%slot-id-set-missing))
132  (set-nargs 3)
133  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
134
135(defarmlapfunction %large-set-slot-id-value ((instance arg_x)
136                                             (slot-id arg_y)
137                                             (new-value arg_z))
138  (ldr temp1 (:@ nfn 'map))
139  (svref temp0 slot-id.index slot-id)
140  (getvheader imm0 temp1)
141  (header-length imm1 imm0)
142  (cmp temp0 imm1)
143  (add imm0 temp0 (:$ arm::misc-data-offset))
144  (ldr temp0 (:@ nfn 'table))
145  (bhs @missing)
146  (ldr imm1 (:@ temp1 imm0))
147  (movs imm1 (:lsl imm1 (:$ arm::fixnumshift)))
148  (add imm1 imm1 (:$ arm::misc-data-offset))
149  (beq @missing)
150  @have-scaled-table-index
151  (ldr temp1 (:@ nfn 'class))
152  (ldr arg_y (:@ temp0 imm1))
153  (ldr nfn (:@ nfn '%maybe-std-setf-slot-value-using-class))
154  (set-nargs 4)
155  (vpush1 temp1)
156  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
157  @missing                              ; (%slot-id-set-missing instance id new-value)
158  (ldr nfn (:@ nfn '%slot-id-ref-missing))
159  (set-nargs 3)
160  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
161)
162
163(defparameter *gf-proto*
164  (nfunction
165   gag
166   (lambda (&lap &lexpr args)
167     (arm-lap-function 
168      gag 
169      ()
170      (vpush-argregs)
171      (vpush1 nargs)
172      (ref-global arg_x ret1valaddr)
173      (add imm1 vsp nargs)
174      (add imm1 imm1 (:$ arm::node-size))                  ; caller's vsp
175      (cmp lr arg_x)
176      (build-lisp-frame imm0 imm1)
177      (mov fn (:$ 0))
178      (moveq lr (:$ (- arm::nil-value arm::fulltag-nil)))
179      (ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return))))
180      (stmdbeq (:! sp) (imm0 imm1 fn lr))
181      (moveq lr arg_x)
182      (movne lr (:$ (- arm::nil-value arm::fulltag-nil)))
183      (ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v))))
184      (mov arg_z vsp)
185      (nth-immediate arg_y gf.dispatch-table nfn) ; dispatch-table
186      (set-nargs 2)
187      (nth-immediate nfn gf.dcode nfn) ; dcode function
188      (ldr pc (:@ nfn (:$ arm::function.entrypoint)))))))
189
190
191     
192     
193
194(defarmlapfunction funcallable-trampoline ()
195  (nth-immediate nfn gf.dcode nfn)
196  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
197
198;;; This can't reference any of the function's constants.
199(defarmlapfunction unset-fin-trampoline ()
200  (build-lisp-frame)
201  (sploadlr .SPheap-rest-arg)                 ; cons up an &rest arg, vpush it
202  (blx lr)
203  (vpop1 arg_z)                          ; whoops, didn't really want to
204  (mov arg_x '#.$XNOFINFUNCTION)
205  (mov arg_y nfn)
206  (set-nargs 3)
207  (sploadlr .SPksignalerr)
208  (blx lr)
209  (mov arg_z 'nil)
210  (return-lisp-frame))
211
212;;; is a winner - saves ~15%
213(defarmlapfunction gag-one-arg ((arg arg_z))
214  (check-nargs 1) 
215  (nth-immediate arg_y gf.dispatch-table nfn) ; mention dt first
216  (set-nargs 2)
217  (nth-immediate nfn gf.dcode nfn)
218  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
219
220
221(defarmlapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z))
222  (check-nargs 2) 
223  (nth-immediate arg_x gf.dispatch-table nfn) ; mention dt first
224  (set-nargs 3)
225  (nth-immediate nfn gf.dcode nfn)
226  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
227
228(defparameter *cm-proto*
229  (nfunction
230   gag
231   (lambda (&lap &lexpr args)
232     (arm-lap-function 
233      gag 
234      ()
235      (vpush-argregs)
236      (vpush1 nargs)
237      (ref-global arg_x ret1valaddr)
238      (add imm1 vsp nargs)
239      (add imm1 imm1 (:$ arm::node-size))                  ; caller's vsp
240      (cmp lr arg_x)
241      (build-lisp-frame imm0 imm1)
242      (mov fn (:$ 0))
243      (moveq lr (:$ (- arm::nil-value arm::fulltag-nil)))
244      (ldreq lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return))))
245      (stmdbeq (:! sp) (imm0 imm1 fn lr))
246      (moveq lr arg_x)
247      (movne lr (:$ (- arm::nil-value arm::fulltag-nil)))
248      (ldrne lr (:@ lr (:$ (arm::%kernel-global 'arm::lexpr-return1v))))
249      (mov arg_z vsp)
250      (nth-immediate arg_y combined-method.thing nfn) ; thing
251      (set-nargs 2)
252      (nth-immediate nfn combined-method.dcode nfn) ; dcode function
253      (ldr pc (:@ nfn (:$ arm::function.entrypoint)))))))
Note: See TracBrowser for help on using the repository browser.