/[cmucl]/src/pcl/low.lisp
ViewVC logotype

Contents of /src/pcl/low.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (show annotations)
Mon Apr 19 02:31:14 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.36: +4 -4 lines
Remove _N"" reader macro from docstrings when possible.
1 ;;;-*-Mode:LISP; Package: PCL -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26 ;;;
27
28 (file-comment
29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/low.lisp,v 1.37 2010/04/19 02:31:14 rtoy Rel $")
30
31 ;;;
32 ;;; This file contains optimized low-level constructs for PCL.
33 ;;;
34
35 (in-package :pcl)
36 (intl:textdomain "cmucl")
37
38 (eval-when (:compile-toplevel :load-toplevel :execute)
39 (defvar *optimize-speed* '(optimize (speed 3) (safety 0)
40 (inhibit-warnings 3) #+small (debug 0.5))))
41
42 ;;; Various macros that include necessary declarations for maximum
43 ;;; performance.
44
45 (defmacro %svref (vector index)
46 `(locally (declare #.*optimize-speed*
47 (inline svref))
48 (svref (the simple-vector ,vector) (the fixnum ,index))))
49
50 (defsetf %svref %set-svref)
51
52 (defmacro %set-svref (vector index new-value)
53 ;; Do it this way so that the evaluation of NEW-VALUE doesn't fall
54 ;; under the *OPTIMIZE-SPEED*.
55 (once-only ((value new-value))
56 `(locally (declare #.*optimize-speed* (inline svref))
57 (setf (svref (the simple-vector ,vector) (the fixnum ,index))
58 ,value))))
59
60 ;;;
61 ;;; With-Pcl-Lock
62 ;;;
63 ;;; Evaluate the body in such a way that no other code that is
64 ;;; running PCL can be run during that evaluation.
65 ;;;
66 ;;; Note that the MP version, which uses a PCL-specific lock
67 ;;; is rather experimental, in that it is not currently clear
68 ;;; if the code inside with-pcl-lock only has to prevent other
69 ;;; threads from entering such sections, or if it really has to
70 ;;; prevent _ALL_ other PCL code (e.g. GF invocations, etc.)
71 ;;; from running. If the latter then we really need to identify
72 ;;; all places that need to acquire the PCL lock, if we are going to
73 ;;; support multiple concurrent threads/processes on SMP machines.
74 ;;;
75 ;;; For the moment we do the experimental thing, and fix any bugs
76 ;;; that occur as a result of this. -- PRM 2002-09-06
77 ;;;
78
79 #-MP
80 (defmacro with-pcl-lock (&body body)
81 `(sys:without-interrupts ,@body))
82
83 #+MP
84 (defvar *global-pcl-lock* (mp:make-lock "Global PCL Lock"))
85
86 #+MP
87 (defmacro with-pcl-lock (&body body)
88 `(mp:with-lock-held (*global-pcl-lock*)
89 ,@body))
90
91
92
93 ;;;
94 ;;; set-function-name
95 ;;; When given a function should give this function the name <new-name>.
96 ;;; Note that <new-name> is sometimes a list.
97 ;;;
98 ;;; When given a funcallable instance, set-function-name MUST side-effect
99 ;;; that FIN to give it the name. When given any other kind of function
100 ;;; set-function-name is allowed to return new function which is the 'same'
101 ;;; except that it has the name.
102 ;;;
103 ;;; In all cases, set-function-name must return the new (or same) function.
104 ;;;
105 (defun set-function-name (function new-name)
106 "Set the name of a compiled function object and return the function."
107 (declare (special *boot-state* *the-class-standard-generic-function*))
108 (when (valid-function-name-p function)
109 (setq function (fdefinition function)))
110 (without-package-locks
111 (when (funcallable-instance-p function)
112 (if (if (eq *boot-state* 'complete)
113 (typep function 'generic-function)
114 (eq (class-of function) *the-class-standard-generic-function*))
115 (setf (kernel:%funcallable-instance-info function 1) new-name)
116 (typecase function
117 (kernel:byte-closure
118 (set-function-name (kernel:byte-closure-function function)
119 new-name))
120 (kernel:byte-function
121 (setf (kernel:byte-function-name function) new-name))
122 (eval:interpreted-function
123 (setf (eval:interpreted-function-name function) new-name))))))
124 (when (memq (car-safe new-name) '(method fast-method slot-accessor))
125 (setf (fdefinition new-name) function))
126 function)
127
128 (defun symbolicate* (pkg &rest things)
129 (let ((*package* pkg))
130 (apply #'symbolicate things)))
131
132 (defun make-.variable. (stem i)
133 (without-package-locks
134 (intern (format nil ".~A~D." (string stem) i)
135 *the-pcl-package*)))
136
137
138 ;;;
139 ;;; COMPILE-LAMBDA
140 ;;;
141 ;;; This is called by PCL to compile generated code (i.e. lambda
142 ;;; forms).
143 ;;;
144 (defvar *compile-lambda-break-p* nil
145 "PCL debugging aid that breaks into the debugger each time
146 `compile-lambda' is invoked.")
147
148 (defvar *compile-lambda-silent-p* t
149 "If true (the default), then `compile-lambda' will try to silence
150 the compiler as completely as possible. Currently this means that
151 `*compile-print*' will be bound to nil during compilation.")
152
153 ;;;
154 ;;; Compile LAMBDA and return the compiled function. If NAME is
155 ;;; specified, set NAME's function definition to the result. If
156 ;;; INLINE is specified, arrange for calls to NAME to be inlined. If
157 ;;; INLINE is :INLINE, arrange to always inline. If INLINE is
158 ;;; :MAYBE-INLINE, let it be inlined only if explicitly requested at
159 ;;; call sites with (DECLARE (INLINE NAME)).
160 ;;;
161 (defun compile-lambda (lambda &key name inline)
162 (declare (type (member nil :inline :maybe-inline) inline)
163 (type (or null symbol cons) name))
164 (when *compile-lambda-break-p*
165 (break))
166 (let* ((*compile-print* (unless *compile-lambda-silent-p* *compile-print*))
167 (fn (compile name lambda)))
168 (when inline
169 (setf (info function inlinep name) inline
170 (info function inline-expansion name) lambda))
171 (if name (fdefinition name) fn)))
172
173 ;;;
174 ;;; This macro will precompile various PCL-generated code fragments,
175 ;;; so that those won't have to be compiled lazily at run-time. For
176 ;;; correct usage the invocation of `precompile-random-code-segments'
177 ;;; needs to be put in a file, which is compiled via `compile-file',
178 ;;; and then loaded.
179 ;;;
180 (defmacro precompile-random-code-segments (&optional system)
181 `(progn
182 (eval-when (:compile-toplevel)
183 (update-dispatch-dfuns))
184 (precompile-function-generators ,system)
185 (precompile-dfun-constructors ,system)
186 (precompile-ctors)))
187
188
189 ;;;; STD-INSTANCE
190
191 ;;; STD-INSTANCE-P is only used to discriminate between functions
192 ;;; (including FINs) and normal instances, so we can return true on
193 ;;; structures also. A few uses of (or std-instance-p fsc-instance-p)
194 ;;; are changed to pcl-instance-p.
195 ;;;
196 (defmacro std-instance-p (x)
197 `(kernel:%instancep ,x))
198
199 (defmacro std-instance-slots (x)
200 `(kernel:%instance-ref ,x 1))
201
202 (defmacro std-instance-hash (x)
203 `(kernel:%instance-ref ,x 2))
204
205 (defmacro std-instance-wrapper (x)
206 `(kernel:%instance-layout ,x))
207
208 (defmacro fsc-instance-p (fin)
209 `(funcallable-instance-p ,fin))
210
211 (defmacro fsc-instance-wrapper (fin)
212 `(kernel:%funcallable-instance-layout ,fin))
213
214 (defmacro fsc-instance-slots (fin)
215 `(kernel:%funcallable-instance-info ,fin 0))
216
217 (defmacro fsc-instance-hash (fin)
218 `(kernel:%funcallable-instance-info ,fin 2))
219
220
221 ;;; PCL-INSTANCE-P is implemented via a compiler transform so that the
222 ;;; test can be optimised away when the result is known, such as is
223 ;;; typically the case during slot access within methods, see
224 ;;; get-slots-or-nil below.
225
226 (in-package "C")
227
228 (defknown pcl::pcl-instance-p (t) boolean
229 (movable foldable flushable explicit-check))
230
231 (deftransform pcl::pcl-instance-p ((object))
232 (let* ((ctype (continuation-type object))
233 (standard-object (specifier-type 'standard-object)))
234 (cond ((csubtypep ctype standard-object)
235 t)
236 ((not (types-intersect ctype standard-object))
237 nil)
238 ((and (kernel::standard-class-p ctype)
239 (let ((class-name (kernel:%class-name ctype)))
240 (or (pcl::info-standard-class-p class-name)
241 (pcl::info-funcallable-standard-class-p class-name))))
242 t)
243 (t
244 `(typep (kernel:layout-of object) 'pcl::wrapper)))))
245
246 (defknown pcl::slot-vector-or-nil (t)
247 (or null simple-vector)
248 (movable foldable flushable))
249
250 (deftransform pcl::slot-vector-or-nil ((object))
251 (let ((ctype (continuation-type object))
252 (funcallable-standard-object
253 (specifier-type 'mop:funcallable-standard-object))
254 (standard-object (specifier-type 'standard-object)))
255 (cond ((or (csubtypep ctype funcallable-standard-object)
256 (and (kernel::standard-class-p ctype)
257 (pcl::info-funcallable-standard-class-p
258 (kernel:%class-name ctype))))
259 '(kernel:%funcallable-instance-info object 0))
260 ((or (csubtypep ctype standard-object)
261 (and (kernel::standard-class-p ctype)
262 (pcl::info-standard-class-p (kernel:%class-name ctype))))
263 '(kernel:%instance-ref object 1))
264 (t
265 `(when (pcl::pcl-instance-p object)
266 (if (pcl::std-instance-p object)
267 (pcl::std-instance-slots object)
268 (pcl::fsc-instance-slots object)))))))
269
270 (in-package "PCL")
271
272 ;;; Definition for interpreted code.
273 (defun slot-vector-or-nil (obj)
274 (when (pcl-instance-p obj)
275 (if (std-instance-p obj)
276 (std-instance-slots obj)
277 (fsc-instance-slots obj))))
278
279 ;;; Definition for interpreted code.
280 (defun pcl-instance-p (x)
281 (typep (kernel:layout-of x) 'wrapper))
282
283 (let ((hash-code 0))
284 (declare (fixnum hash-code))
285 (defun get-instance-hash-code ()
286 (if (< hash-code most-positive-fixnum)
287 (incf hash-code)
288 (setq hash-code 0))))
289
290 ;;;
291 ;;; We define this as STANDARD-INSTANCE, since we're going to clobber the
292 ;;; layout with some standard-instance layout as soon as we make it, and we
293 ;;; want the accesor to still be type-correct.
294 ;;;
295 (defstruct (standard-instance
296 (:predicate nil)
297 (:constructor %%allocate-instance--class ())
298 (:alternate-metaclass kernel:instance kernel::standard-class
299 kernel:make-standard-class))
300 (slots nil)
301 (hash-code (get-instance-hash-code) :type fixnum))
302
303
304 (defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x))
305
306 (defmacro get-wrapper (inst)
307 (once-only ((wrapper `(wrapper-of ,inst)))
308 `(progn
309 (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?")
310 ,wrapper)))
311
312 (defmacro get-instance-wrapper-or-nil (inst)
313 (once-only ((wrapper `(wrapper-of ,inst)))
314 `(if (typep ,wrapper 'wrapper)
315 ,wrapper
316 nil)))
317
318 (defmacro get-slots (inst)
319 `(cond ((std-instance-p ,inst) (std-instance-slots ,inst))
320 ((fsc-instance-p ,inst) (fsc-instance-slots ,inst))
321 (t (internal-error "What kind of instance is this?"))))
322
323 (defmacro get-slots-or-nil (inst)
324 (once-only ((n-inst inst))
325 `(when (pcl-instance-p ,n-inst)
326 (if (std-instance-p ,n-inst)
327 (std-instance-slots ,n-inst)
328 (fsc-instance-slots ,n-inst)))))
329
330 (defun print-std-instance (instance stream depth)
331 (declare (ignore depth))
332 (print-unreadable-object (instance stream :identity t)
333 (let ((class (class-of instance)))
334 (if (or (eq class (find-class 'standard-class nil))
335 (eq class (find-class 'funcallable-standard-class nil))
336 (eq class (find-class 'built-in-class nil)))
337 (format stream "~a ~a" (early-class-name class)
338 (early-class-name instance))
339 (format stream "~a" (early-class-name class))))))
340
341 ;;; Slot access itself
342
343 (defmacro %slot-ref (slots index)
344 `(%svref ,slots ,index))
345
346 (defmacro slot-ref (slots index)
347 `(svref ,slots ,index))
348
349 ;;;
350 ;;; Like KERNEL::PARSE-LAMBDA-LIST, but check for repeated lambda
351 ;;; variable and &MORE.
352 ;;;
353 (defun parse-lambda-list (lambda-list &optional specialized-p)
354 (multiple-value-bind (required optional restp rest keyp keys
355 allow-other-keys-p aux morep)
356 (kernel:parse-lambda-list lambda-list)
357 (when morep
358 (simple-program-error "~@<~s not allowed here~@:>" 'c:&more))
359 (collect ((vars))
360 (labels ((check-var (var)
361 (cond ((not (symbolp var))
362 (simple-program-error
363 "~@<Invalid lambda variable: ~s~@:>" var))
364 ((memq var (vars))
365 (simple-program-error
366 "~@<Repeated lambda variable: ~s~@:>" var))
367 (t
368 (vars var))))
369 (check-required (var)
370 (if (and (consp var) specialized-p)
371 (check-var (car var))
372 (check-var var)))
373 (check-optional (var)
374 (if (consp var)
375 (destructuring-bind (var &optional value supplied-p)
376 var
377 (declare (ignore value))
378 (if (consp var)
379 (check-var (cadr var))
380 (check-var var))
381 (when supplied-p
382 (check-var supplied-p)))
383 (check-var var))))
384 (mapc #'check-required required)
385 (mapc #'check-optional optional)
386 (mapc #'check-optional keys)
387 (when restp (check-var rest))
388 (mapc #'check-optional aux)
389 (values required optional restp rest keyp keys
390 allow-other-keys-p aux)))))
391
392
393 ;;;
394 ;;; The problem with unbound markers is that they cannot be dumped to
395 ;;; fasl files. So, we need to create unbound markers in some way,
396 ;;; which can be done by returning one from a compiled function. The
397 ;;; problem with that is that it's awefully slow, and inlining the
398 ;;; function creating the unbound marker doesn't work with interpreted
399 ;;; code, because C::%%PRIMITIVE, which is used to create the unbound
400 ;;; marker isn't defined when inlining happens. Using LOAD-TIME-VALUE
401 ;;; and a symbol macro is relatively fast, but not fast enough.
402 ;;;
403 ;;; Maybe one should support dumping unbound markers to fasl files?
404 ;;;
405 #+nil
406 (progn
407 (defun make-unbound-marker ()
408 (lisp::%primitive c:make-other-immediate-type 0 vm:unbound-marker-type))
409 (define-symbol-macro +slot-unbound+
410 (load-time-value (make-unbound-marker) t)))
411
412 #-nil
413 (defconstant +slot-unbound+ '..slot-unbound..)
414
415 (defun internal-error (format-control &rest format-args)
416 (error (format nil "~~@<Internal error: ~?~~@:>"
417 format-control format-args)))
418
419 (defun internal-program-error (name &rest args)
420 (error 'kernel:simple-program-error
421 :function-name name
422 :format-control (car args)
423 :format-arguments (list (cdr args))))
424
425 ;;;; Structure-instance stuff:
426
427 (defun structure-instance-p (x)
428 (typep x 'lisp:structure-object))
429
430 (defun structurep (x)
431 (typep x 'lisp:structure-object))
432
433 (defun structure-type (x)
434 (kernel:%class-name (kernel:layout-class (kernel:%instance-layout x))))
435
436 ;;;
437 ;;; Return true if TYPE is the name of a structure. Note that we
438 ;;; return false for conditions, which aren't "real" structures.
439 ;;;
440 (defun structure-type-p (type)
441 (and (symbolp type)
442 (not (condition-type-p type))
443 (let ((class (kernel::find-class type nil)))
444 (and class
445 ;; class may not be complete if created by
446 ;; inform-type-system-aboutd-std-class
447 (kernel:%class-layout class)
448 (typep (kernel:layout-info (kernel:%class-layout class))
449 'kernel:defstruct-description)))))
450
451 ;;;
452 ;;; Returne true if TYPE is the name of a condition.
453 ;;;
454 (defun condition-type-p (type)
455 (and (symbolp type)
456 (conditions::condition-class-p (kernel::find-class type nil))))
457
458 (defun get-structure-dd (type)
459 (kernel:layout-info (kernel:%class-layout (kernel::find-class type))))
460
461 (defun structure-type-included-type-name (type)
462 (let ((include (kernel::dd-include (get-structure-dd type))))
463 (if (consp include)
464 (car include)
465 include)))
466
467 (defun structure-type-slot-description-list (type)
468 (nthcdr (length (let ((include (structure-type-included-type-name type)))
469 (and include (kernel:dd-slots (get-structure-dd include)))))
470 (kernel:dd-slots (get-structure-dd type))))
471
472 (defun structure-slotd-name (slotd)
473 (kernel:dsd-name slotd))
474
475 (defun structure-slotd-accessor-symbol (slotd)
476 (kernel:dsd-accessor slotd))
477
478 (defun structure-slotd-reader-function (slotd)
479 (fdefinition (kernel:dsd-accessor slotd)))
480
481 (defun structure-slotd-writer-function (type dsd)
482 (if (kernel:dsd-read-only dsd)
483 (multiple-value-bind (accessor offset data)
484 (kernel::slot-accessor-form (get-structure-dd type) dsd)
485 (compile-lambda
486 `(lambda (new-value kernel::object)
487 (setf (,accessor ,data ,offset) new-value)
488 new-value)))
489 (fdefinition `(setf ,(kernel:dsd-accessor dsd)))))
490
491 (defun structure-slotd-type (slotd)
492 (kernel:dsd-type slotd))
493
494 (defun structure-slotd-init-form (slotd)
495 (kernel::dsd-default slotd))
496
497
498 ;;;
499 ;;; Extractor for source context information, which is used by the
500 ;;; compiler to indicate progress and context information for error
501 ;;; reporting.
502 ;;;
503
504 (defun kernel::kernel-class-of-pcl-class (class)
505 (kernel::find-class (class-name class)))
506
507 (in-package "C")
508
509 (def-source-context pcl:defmethod (name &rest stuff)
510 (let ((arg-pos (position-if #'listp stuff)))
511 (if arg-pos
512 `(pcl:defmethod ,name ,@(subseq stuff 0 arg-pos)
513 ,(nth-value 2 (pcl::parse-specialized-lambda-list
514 (elt stuff arg-pos))))
515 `(pcl:defmethod ,name "<illegal syntax>"))))
516
517 (in-package "PCL")
518
519 #+bootable-pcl
520 (defun early-pcl-init ()
521 ;; defsys
522 (setq *the-pcl-package* (find-package "PCL"))
523 (setq *boot-state* nil)
524 (setq *dfun-constructors* nil)
525 ;;
526 ;; Show us when we use the compiler.
527 (setq *compile-lambda-silent-p* nil)
528 ;;
529 ;; Wait with installing optimized constructors until we can
530 ;; invoke the compiler.
531 (setq *cold-boot-state* t))
532
533 #+bootable-pcl
534 (defun final-pcl-init ()
535 (setq *cold-boot-state* nil)
536 (setq *compile-lambda-silent-p* t)
537 (dolist (ctor *all-ctors*)
538 (install-optimized-constructor ctor)))
539
540 ;;; end of low.lisp

  ViewVC Help
Powered by ViewVC 1.1.5