source: trunk/source/level-0/l0-symbol.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.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.8 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;;; No error checking, no interrupts, no protect_caller, no nuthin.
21;;; No error, no cons.  No problem.
22(defun %progvrestore (saved)
23  (declare (optimize (speed 3) (safety 0)))
24  (dolist (pair saved)
25    (%set-sym-value (car pair) (cdr pair))))
26
27;;; Check that something that's supposed to be a proper list of
28;;; symbols is; error otherwise.
29;;; This is called only by the compiler output of a PROGV form.
30;;; It checks for the maximum length that the progvsave subprim
31;;; can handle.
32
33(defun check-symbol-list (l &optional (max-length
34                                        (floor (- 4096 20) (* target::node-size 3))
35                                       ))
36  (let ((len (list-length l)))
37    (if (and len
38             (or (null max-length)
39                 (< len max-length))
40             (dolist (s l t) 
41               (unless (and (symbolp s)
42                            (not (constant-symbol-p s))
43                            (not (logbitp $sym_vbit_global (the fixnum (%symbol-bits s))))
44                            (ensure-binding-index s))
45                 (return nil))))
46      l
47      (error "~s is not a proper list of bindable symbols~@[ of length < ~s~]." l max-length))))
48
49;;; The type-checking done on the "plist" arg shouldn't be removed.
50(defun set-symbol-plist (sym plist)
51  (when plist
52    (let* ((len (list-length plist)))
53      (unless (and len (evenp len))
54        (error "Bad plist: ~s" plist))))
55  (let* ((vector (symptr->symvector (%symbol->symptr sym)))
56         (cell (%svref vector target::symbol.plist-cell))
57         (consp (consp cell)))
58    (if plist
59      (if consp
60        (setf (cdr cell) plist)
61        (cdr (setf (%svref vector target::symbol.plist-cell) (cons nil plist))))
62      (progn
63        (if consp
64          (setf (%svref vector target::symbol.plist-cell) (%car cell)))
65        nil))))
66
67
68(eval-when (:compile-toplevel :execute)
69  (declaim (inline %pl-search)))
70
71(defun %pl-search (l key)
72  (declare (list l) (optimize (speed 3)))
73  (loop
74    (if (eq (car l) key)
75      (return)
76      (if l
77        (setq l (cdr (the list (cdr l))))
78        (return))))
79  l)
80
81
82(defun symbol-plist (sym)
83  "Return SYMBOL's property list."
84  (let* ((cell (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell)))
85    (if (consp cell)
86      (cdr cell))))
87
88
89(defun get (sym key &optional default)
90  "Look on the property list of SYMBOL for the specified INDICATOR. If this
91  is found, return the associated value, else return DEFAULT."
92  (let* ((cell (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell))
93         (tail (if (consp cell)
94                 (%pl-search (cdr cell ) key))))
95    (if tail (%cadr tail) default)))
96
97(defun put (sym key value)
98  (let* ((symptr (%symbol->symptr sym))
99         (vector (symptr->symvector symptr))
100         (cell  (%svref vector target::symbol.plist-cell))
101         (plist (if (consp cell) (cdr cell)))
102         (tail (%pl-search plist key)))
103    (if tail 
104      (%rplaca (%cdr tail) value)
105      (progn
106        (setq plist (cons key (cons value plist)))
107        (if (consp cell)
108          (setf (cdr cell) plist)
109          (setf (%svref vector target::symbol.plist-cell) (cons nil plist)))))
110    value))
111
112
113(defun get-type-predicate (name)
114  (let* ((symvec (symptr->symvector (%symbol->symptr name)))
115         (pp (%svref symvec target::symbol.package-predicate-cell)))
116    (if (consp pp)
117      (%cdr pp))))
118
119(defun set-type-predicate (name function)
120  (let* ((bits (%symbol-bits name))
121         (symvec (symptr->symvector (%symbol->symptr name)))
122         (spp (%svref symvec target::symbol.package-predicate-cell)))
123    (declare (fixnum bits))
124    (if (logbitp $sym_vbit_typeppred bits)
125      (%rplacd spp function)
126      (progn
127        (%symbol-bits name (the fixnum (bitset $sym_vbit_typeppred bits)))
128        (setf (%svref symvec target::symbol.package-predicate-cell) (cons spp function))))
129    function))
130
131(defun symbol-value (sym)
132  "Return SYMBOL's current bound value."
133  (let* ((val (%sym-value sym)))
134    (if (eq val (%unbound-marker))
135      (%kernel-restart $xvunbnd sym)
136      val)))
137
138(defun set (sym value)
139  "Set SYMBOL's value cell to NEW-VALUE."
140  (let* ((bits (%symbol-bits sym)))
141    (declare (fixnum bits))
142    (if (logbitp $sym_vbit_const bits)
143      (%err-disp $XCONST sym)
144      (%set-sym-value sym value))))
145
146(defun constant-symbol-p (sym)
147  (and (symbolp sym)
148       (%ilogbitp $sym_vbit_const (%symbol-bits sym))))
149
150;;; This leaves the SPECIAL bit alone, clears the others.
151(defun makunbound (sym)
152  "Make SYMBOL unbound, removing any value it may currently have."
153  (if (and *warn-if-redefine-kernel*
154           (constant-symbol-p sym))
155    (cerror "Make ~S be unbound anyway."
156            "~S is a constant; making it unbound might be a bad idea." sym))
157  (%symbol-bits sym (the fixnum (logand (logior #xff00 (ash 1 $sym_bit_special))
158                                        (the fixnum (%symbol-bits sym)))))
159  (%set-sym-value sym (%unbound-marker))
160  sym)
161
162(defun non-nil-symbolp (x)
163  "Returns symbol if true"
164  (if (symbolp x) x))
165
166(defun symbol-package (sym)
167  "Return the package SYMBOL was interned in, or NIL if none."
168  (let* ((pp (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.package-predicate-cell)))
169    (if (consp pp) (car pp) pp)))
170
171(defun boundp (sym)
172  "Return non-NIL if SYMBOL is bound to a value."
173  (not (eq (%sym-value sym) (%unbound-marker))))
174
175(defun make-symbol (name)
176  "Make and return a new symbol with the NAME as its print name."
177  (symvector->symptr
178   (%gvector target::subtag-symbol
179             (ensure-simple-string name) ; pname
180             (%unbound-marker)          ; value cell
181             %unbound-function%         ; function cell
182             nil                        ; package&predicate
183             0                          ; flags
184             nil                        ; plist
185             0)))                       ; binding-index
186
187(defun %symbol-bits (sym &optional new)
188  (let* ((p (%symbol->symptr sym))
189         (bits (%svref (symptr->symvector p) target::symbol.flags-cell)))
190    (if new
191      (setf (%svref (symptr->symvector p) target::symbol.flags-cell) new))
192    bits))
193
194(defun %sym-value (name)
195  (%symptr-value (%symbol->symptr name)))
196
197(defun %set-sym-value (name val)
198  (%set-symptr-value (%symbol->symptr name) val))
199   
200(defun %sym-global-value (name)
201  (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell))
202
203(defun %set-sym-global-value (name val)
204  (setf (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell) val))
205
206(defun symbol-name (sym)
207  "Return SYMBOL's name as a string."
208  #+(or ppc32-target x8632-target x8664-target arm-target)
209  (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.pname-cell)
210  #+ppc64-target
211  (if sym                               ;NIL's pname is implicit
212    (%svref (%symbol->symptr sym) ppc64::symbol.pname-cell)
213    "NIL")
214  )
215
216
217
218
219(defun %global-macro-function (symbol)
220  (let* ((fbinding (fboundp symbol)))
221    (if (and #-arm-target (typep fbinding 'simple-vector)
222             #+arm-target (= (typecode fbinding) arm::subtag-pseudofunction)
223             (= (the fixnum (uvsize fbinding)) #-arm-target 2 #+arm-target 3))
224      (let* ((fun (%svref fbinding #-arm-target 1 #+arm-target 2)))
225        (if (functionp fun) fun)))))
226
227(defun %symbol-binding-address (sym)
228  (%symptr-binding-address (%symbol->symptr sym)))
229
230(defun symbol-binding-index (sym)
231  (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell))
232
233(defvar *interrupt-level* -1)
234
235;;; Special binding indices, and the inverse mapping between indices
236;;; and symbols
237(let* ((binding-index-lock (make-lock))
238       (binding-index-reverse-map (make-hash-table :test #'eq :weak :value))
239       (next-binding-index 0))
240  (defun %set-binding-index (val) (setq next-binding-index val))
241  (defun next-binding-index () (1+ next-binding-index))
242  (defun ensure-binding-index (sym)
243    (with-lock-grabbed (binding-index-lock)
244      (let* ((symvec (symptr->symvector (%symbol->symptr sym)))
245             (idx (%svref symvec target::symbol.binding-index-cell))
246             (bits (%symbol-bits sym)))
247        (declare (fixnum idx bits))
248        (if (or (logbitp $sym_vbit_global bits)
249                (logbitp $sym_vbit_const bits))
250          (unless (zerop idx)
251            (remhash idx binding-index-reverse-map)
252            (setf (%svref symvec target::symbol.binding-index-cell) 0))
253          (if (zerop idx)
254            (let* ((new-idx (incf next-binding-index)))
255              (setf (%svref symvec target::symbol.binding-index-cell) new-idx)
256              (setf (gethash new-idx binding-index-reverse-map) sym))))
257        sym)))
258  (defun binding-index-symbol (idx)
259    (with-lock-grabbed (binding-index-lock)
260      (gethash idx binding-index-reverse-map)))
261  (defun cold-load-binding-index (sym)
262    ;; Index may have been assigned via xloader.  Update
263    ;; reverse map
264    (with-lock-grabbed (binding-index-lock)
265      (let* ((idx (%svref (symptr->symvector (%symbol->symptr sym))
266                          target::symbol.binding-index-cell)))
267        (declare (fixnum idx))
268        (unless (zerop idx)
269          (setf (gethash idx binding-index-reverse-map) sym))))))
270
271       
272
Note: See TracBrowser for help on using the repository browser.