/[gcl]/gcl/pcl/gcl_pcl_fast_init.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_fast_init.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 1 
1    ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
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    ;;; This file defines the optimized make-instance functions.
29    ;;;
30    
31    (in-package :pcl)
32    
33    (defvar *compile-make-instance-functions-p* nil)
34    
35    (defun update-make-instance-function-table (&optional (class *the-class-t*))
36      (when (symbolp class) (setq class (find-class class)))
37        (when (eq class *the-class-t*) (setq class *the-class-slot-object*))
38        (when (memq *the-class-slot-object* (class-precedence-list class))
39          (map-all-classes #'reset-class-initialize-info class)))
40    
41    (defun constant-symbol-p (form)
42      (and (constantp form)
43           (let ((object (eval form)))
44             (and (symbolp object)
45                  (symbol-package object)))))
46    
47    (defvar *make-instance-function-keys* nil)
48    
49    (defun expand-make-instance-form (form)
50      (let ((class (cadr form)) (initargs (cddr form))
51            (keys nil)(allow-other-keys-p nil) key value)
52        (when (and (constant-symbol-p class)
53                   (let ((initargs-tail initargs))
54                     (loop (when (null initargs-tail) (return t))
55                           (unless (constant-symbol-p (car initargs-tail))
56                             (return nil))                
57                           (setq key (eval (pop initargs-tail)))
58                           (setq value (pop initargs-tail))
59                           (when (eq ':allow-other-keys key)
60                             (setq allow-other-keys-p value))
61                           (push key keys))))
62          (let* ((class (eval class))
63                 (keys (nreverse keys))
64                 (key (list class keys allow-other-keys-p))
65                 (sym (make-instance-function-symbol key)))
66            (push key *make-instance-function-keys*)
67            (when sym
68              `(,sym ',class ,@initargs))))))
69    
70    (defmacro expanding-make-instance-top-level (&rest forms &environment env)
71      (let* ((*make-instance-function-keys* nil)
72             (form (macroexpand `(expanding-make-instance ,@forms) env)))
73        `(progn
74           ,@(when *make-instance-function-keys*
75               `((get-make-instance-functions ',*make-instance-function-keys*)))
76           ,form)))
77              
78    (defmacro expanding-make-instance (&rest forms &environment env)
79      `(progn
80         ,@(mapcar #'(lambda (form)
81                       (walk-form form env
82                                  #'(lambda (subform context env)
83                                      (declare (ignore env))
84                                      (or (and (eq context ':eval)
85                                               (consp subform)
86                                               (eq (car subform) 'make-instance)
87                                               (expand-make-instance-form subform))
88                                          subform))))
89                   forms)))
90    
91    (defmacro defconstructor
92              (name class lambda-list &rest initialization-arguments)
93      `(expanding-make-instance-top-level
94        (defun ,name ,lambda-list
95          (make-instance ',class ,@initialization-arguments))))
96    
97    (defun get-make-instance-functions (key-list)
98      (dolist (key key-list)
99        (let* ((cell (find-class-cell (car key)))
100               (make-instance-function-keys
101                (find-class-cell-make-instance-function-keys cell))
102               (mif-key (cons (cadr key) (caddr key))))
103          (unless (find mif-key make-instance-function-keys
104                        :test #'equal)
105            (push mif-key (find-class-cell-make-instance-function-keys cell))
106            (let ((class (find-class-cell-class cell)))
107              (when (and class (not (forward-referenced-class-p class)))
108                (update-initialize-info-internal
109                 (initialize-info class (car mif-key) nil (cdr mif-key))
110                 'make-instance-function)))))))
111    
112    (defun make-instance-function-symbol (key)
113      (let* ((class (car key))
114             (symbolp (symbolp class)))
115        (when (or symbolp (classp class))
116          (let* ((class-name (if (symbolp class) class (class-name class)))
117                 (keys (cadr key))
118                 (allow-other-keys-p (caddr key)))
119            (when (and (or symbolp
120                           (and (symbolp class-name)
121                                (eq class (find-class class-name nil))))
122                       (symbol-package class-name))
123              (let ((*package* *the-pcl-package*)
124                    (*print-length* nil) (*print-level* nil)
125                    (*print-circle* nil) (*print-case* :upcase)
126                    (*print-pretty* nil))
127                (intern (format nil "MAKE-INSTANCE ~S ~S ~S"
128                                class-name keys allow-other-keys-p))))))))
129    
130    (defun make-instance-1 (class &rest initargs)
131      (apply #'make-instance class initargs))
132    
133    (defmacro define-cached-reader (type name trap)
134      (let ((reader-name (intern (format nil "~A-~A" type name)))
135            (cached-name (intern (format nil "~A-CACHED-~A" type name))))
136        `(defmacro ,reader-name (info)
137           `(let ((value (,',cached-name ,info)))
138              (if (eq value ':unknown)
139                  (progn
140                    (,',trap ,info ',',name)
141                    (,',cached-name ,info))
142                  value)))))
143    
144    (eval-when (compile load eval)
145    (defparameter initialize-info-cached-slots
146      '(valid-p                             ; t or (:invalid key)
147        ri-valid-p
148        initargs-form-list
149        combined-initargs-form-list
150        new-keys
151        default-initargs-function
152        shared-initialize-t-function
153        shared-initialize-nil-function
154        constants
155        combined-initialize-function ; allocate-instance + shared-initialize
156        make-instance-function ; nil means use gf
157        make-instance-function-symbol)))
158    
159    (defmacro define-initialize-info ()
160      (let ((cached-slot-names
161             (mapcar #'(lambda (name)
162                         (intern (format nil "CACHED-~A" name)))
163                     initialize-info-cached-slots))
164            (cached-names
165             (mapcar #'(lambda (name)
166                         (intern (format nil "~A-CACHED-~A"
167                                         'initialize-info name)))
168                     initialize-info-cached-slots)))
169        `(progn
170           (defstruct initialize-info
171             key wrapper
172             ,@(mapcar #'(lambda (name)
173                           `(,name :unknown))
174                       cached-slot-names))
175           (defmacro reset-initialize-info-internal (info)
176             `(progn
177                ,@(mapcar #'(lambda (cname)
178                              `(setf (,cname ,info) ':unknown))
179                          ',cached-names)))
180           (defun initialize-info-bound-slots (info)
181             (let ((slots nil))
182               ,@(mapcar #'(lambda (name cached-name)
183                             `(unless (eq ':unknown (,cached-name info))
184                                (push ',name slots)))
185                         initialize-info-cached-slots cached-names)
186               slots))
187          ,@(mapcar #'(lambda (name)
188                        `(define-cached-reader initialize-info ,name
189                          update-initialize-info-internal))
190                    initialize-info-cached-slots))))
191    
192    (define-initialize-info)
193    
194    (defvar *initialize-info-cache-class* nil)
195    (defvar *initialize-info-cache-initargs* nil)
196    (defvar *initialize-info-cache-info* nil)
197    
198    (defvar *revert-initialize-info-p* nil)
199    
200    (defun reset-initialize-info (info)
201      (setf (initialize-info-wrapper info)
202            (class-wrapper (car (initialize-info-key info))))
203      (let ((slots-to-revert (if *revert-initialize-info-p*
204                                 (initialize-info-bound-slots info)
205                                 '(make-instance-function))))
206        (reset-initialize-info-internal info)
207        (dolist (slot slots-to-revert)
208          (update-initialize-info-internal info slot))
209        info))
210    
211    (defun reset-class-initialize-info (class)
212      (reset-class-initialize-info-1 (class-initialize-info class)))
213    
214    (defun reset-class-initialize-info-1 (cell)
215      (when (consp cell)
216        (when (car cell)
217          (reset-initialize-info (car cell)))
218        (let ((alist (cdr cell)))
219          (dolist (a alist)
220            (reset-class-initialize-info-1 (cdr a))))))
221    
222    (defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
223      (let ((info nil))
224        (if (and (eq *initialize-info-cache-class* class)
225                 (eq *initialize-info-cache-initargs* initargs))
226            (setq info *initialize-info-cache-info*)
227            (let ((initargs-tail initargs)
228                  allow-other-keys-p
229                  (cell (or (class-initialize-info class)
230                            (setf (class-initialize-info class) (cons nil nil)))))
231              (loop (when (null initargs-tail) (return nil))
232                    (let ((keyword (pop initargs-tail))
233                          (alist-cell cell))
234                      (when plist-p
235                        ;; leftmost occurrence only
236                        ;; FIXME check that this is correct
237                        (if (and (not allow-other-keys-p) (eq keyword :allow-other-keys))
238                            (progn
239                              (setq allow-other-keys-arg (pop initargs-tail))
240                              (setq allow-other-keys-p t))
241                            (pop initargs-tail)))
242                      (loop (let ((alist (cdr alist-cell)))
243                              (when (null alist)
244                                (setq cell (cons nil nil))
245                                (setf (cdr alist-cell) (list (cons keyword cell)))
246                                (return nil))
247                              (when (eql keyword (caar alist))
248                                (setq cell (cdar alist))
249                                (return nil))
250                              (setq alist-cell alist)))))
251              (setq info (or (car cell)
252                             (setf (car cell) (make-initialize-info))))))
253        (let ((wrapper (initialize-info-wrapper info)))
254          (unless (eq wrapper (class-wrapper class))
255            (unless wrapper
256              (let* ((initargs-tail initargs)
257                     (klist-cell (list nil))
258                     (klist-tail klist-cell))
259                (loop (when (null initargs-tail) (return nil))
260                      (let ((key (pop initargs-tail)))
261                        (setf (cdr klist-tail) (list key)))
262                      (setf klist-tail (cdr klist-tail))
263                      (when plist-p (pop initargs-tail)))
264                (setf (initialize-info-key info)
265                      (list class (cdr klist-cell) allow-other-keys-arg))))
266            (reset-initialize-info info)))
267        (setq *initialize-info-cache-class* class)
268        (setq *initialize-info-cache-initargs* initargs)
269        (setq *initialize-info-cache-info* info)    
270        info))
271    
272    (defun update-initialize-info-internal (info name)
273      (let* ((key (initialize-info-key info))
274             (class (car key))
275             (keys (cadr key))
276             (allow-other-keys-arg (caddr key)))
277        (ecase name
278          ((initargs-form-list new-keys)
279           (multiple-value-bind (initargs-form-list new-keys)
280               (make-default-initargs-form-list class keys)
281             (setf (initialize-info-cached-initargs-form-list info) initargs-form-list)
282             (setf (initialize-info-cached-new-keys info) new-keys)))
283          ((combined-initargs-form-list)
284           (multiple-value-bind (initargs-form-list new-keys)
285               (make-default-initargs-form-list class keys nil)
286             (setf (initialize-info-cached-combined-initargs-form-list info)
287                   initargs-form-list)
288             (setf (initialize-info-cached-new-keys info) new-keys)))
289          ((default-initargs-function)
290           (let ((initargs-form-list (initialize-info-initargs-form-list info)))
291             (setf (initialize-info-cached-default-initargs-function info)
292                   (initialize-instance-simple-function
293                    'default-initargs-function info
294                    class initargs-form-list))))
295          ((valid-p ri-valid-p)
296           (flet ((compute-valid-p (methods)
297                    (or (not (null allow-other-keys-arg))
298                        (multiple-value-bind (legal allow-other-keys)
299                            (check-initargs-values class methods)
300                          (or (not (null allow-other-keys))
301                              (dolist (key keys t)
302                                (unless (or (member key legal) (eq key :allow-other-keys))
303                                  (return (cons :invalid key)))))))))
304             (let ((proto (class-prototype class)))
305               (setf (initialize-info-cached-valid-p info)
306                     (compute-valid-p
307                      (list (list* 'allocate-instance class nil)
308                            (list* 'initialize-instance proto nil)
309                            (list* 'shared-initialize proto t nil))))
310               (setf (initialize-info-cached-ri-valid-p info)
311                     (compute-valid-p
312                      (list (list* 'reinitialize-instance proto nil)
313                            (list* 'shared-initialize proto nil nil)))))))
314          ((shared-initialize-t-function)
315           (multiple-value-bind (initialize-form-list ignore)
316               (make-shared-initialize-form-list class keys t nil)
317             (declare (ignore ignore))
318             (setf (initialize-info-cached-shared-initialize-t-function info)
319                   (initialize-instance-simple-function
320                    'shared-initialize-t-function info
321                    class initialize-form-list))))
322          ((shared-initialize-nil-function)
323           (multiple-value-bind (initialize-form-list ignore)
324               (make-shared-initialize-form-list class keys nil nil)
325             (declare (ignore ignore))
326             (setf (initialize-info-cached-shared-initialize-nil-function info)
327                   (initialize-instance-simple-function
328                    'shared-initialize-nil-function info
329                    class initialize-form-list))))
330          ((constants combined-initialize-function)
331           (let ((initargs-form-list (initialize-info-combined-initargs-form-list info))
332                 (new-keys (initialize-info-new-keys info)))
333             (multiple-value-bind (initialize-form-list constants)
334                 (make-shared-initialize-form-list class new-keys t t)
335               (setf (initialize-info-cached-constants info) constants)
336               (setf (initialize-info-cached-combined-initialize-function info)
337                     (initialize-instance-simple-function
338                      'combined-initialize-function info
339                      class (append initargs-form-list initialize-form-list))))))
340          ((make-instance-function-symbol)
341           (setf (initialize-info-cached-make-instance-function-symbol info)
342                 (make-instance-function-symbol key)))
343          ((make-instance-function)
344           (let* ((function (get-make-instance-function key))
345                  (symbol (initialize-info-make-instance-function-symbol info)))
346             (setf (initialize-info-cached-make-instance-function info) function)
347             (when symbol (setf (gdefinition symbol)
348                                (or function #'make-instance-1)))))))
349      info)
350    
351    (defun get-make-instance-function (key)
352      (let* ((class (car key))
353             (keys (cadr key)))
354        (unless (eq *boot-state* 'complete)
355          (return-from get-make-instance-function nil))
356        (when (symbolp class)
357          (setq class (find-class class)))
358        (when (classp class)
359          (unless (class-finalized-p class) (finalize-inheritance class)))
360        (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
361               (class-and-initargs (list* class initargs))
362               (make-instance (gdefinition 'make-instance))
363               (make-instance-methods
364                (compute-applicable-methods make-instance class-and-initargs))
365               (std-mi-meth (find-standard-ii-method make-instance-methods 'class))
366               (class+initargs (list class initargs))
367               (default-initargs (gdefinition 'default-initargs))
368               (default-initargs-methods
369                   (compute-applicable-methods default-initargs class+initargs))
370               (proto (and (classp class) (class-prototype class)))
371               (initialize-instance-methods
372                (when proto
373                  (compute-applicable-methods (gdefinition 'initialize-instance)
374                                              (list* proto initargs))))
375               (shared-initialize-methods
376                (when proto
377                  (compute-applicable-methods (gdefinition 'shared-initialize)
378                                              (list* proto t initargs)))))
379          (when (null make-instance-methods)
380            (return-from get-make-instance-function
381              #'(lambda (class &rest initargs)
382                  (apply #'no-applicable-method make-instance class initargs))))
383          (unless (and (null (cdr make-instance-methods))
384                       (eq (car make-instance-methods) std-mi-meth)
385                       (null (cdr default-initargs-methods))
386                       (eq (car (method-specializers (car default-initargs-methods)))
387                           *the-class-slot-class*)
388                       (flet ((check-meth (meth)
389                                (let ((quals (method-qualifiers meth)))
390                                  (if (null quals)
391                                      (eq (car (method-specializers meth))
392                                          *the-class-slot-object*)
393                                      (and (null (cdr quals))
394                                           (or (eq (car quals) ':before)
395                                               (eq (car quals) ':after)))))))
396                         (and (every #'check-meth initialize-instance-methods)
397                              (every #'check-meth shared-initialize-methods))))
398            (return-from get-make-instance-function nil))
399          (get-make-instance-function-internal
400           class key (default-initargs class initargs)
401           initialize-instance-methods shared-initialize-methods))))
402    
403    (defun get-make-instance-function-internal (class key initargs
404                                                      initialize-instance-methods
405                                                      shared-initialize-methods)
406      (let* (#|(class-key (car key))|#
407             (keys (cadr key))
408             (allow-other-keys-p (caddr key))
409             (allocate-instance-methods
410              (compute-applicable-methods (gdefinition 'allocate-instance)
411                                          (list* class initargs))))
412        (unless allow-other-keys-p
413          (unless (check-initargs-1
414                   class initargs
415                   (append allocate-instance-methods
416                           initialize-instance-methods
417                           shared-initialize-methods)
418                   t nil)
419            (return-from get-make-instance-function-internal nil)))
420        (cond ((or (cdr allocate-instance-methods)
421                   (some #'complicated-instance-creation-method
422                         initialize-instance-methods)
423                   (some #'complicated-instance-creation-method
424                         shared-initialize-methods))
425               (make-instance-function-complex
426                key class keys
427                initialize-instance-methods shared-initialize-methods))
428              (t #|(or (not (standard-class-p class)) (not (symbolp class-key))
429                   initialize-instance-methods shared-initialize-methods)|#
430               (make-instance-function-simple
431                key class keys
432                initialize-instance-methods shared-initialize-methods))
433              #|(t
434               (make-instance-function-basic
435                key class keys))|#)))
436    
437    (defun complicated-instance-creation-method (m)
438      (let ((qual (method-qualifiers m)))
439        (if qual
440            (not (and (null (cdr qual)) (eq (car qual) ':after)))
441            (let ((specl (car (method-specializers m))))
442              (or (not (classp specl))
443                  (not (eq 'slot-object (class-name specl))))))))
444    
445    (defun find-standard-ii-method (methods class-names)
446      (dolist (m methods)
447        (when (null (method-qualifiers m))
448          (let ((specl (car (method-specializers m))))
449            (when (and (classp specl)
450                       (if (listp class-names)
451                           (member (class-name specl) class-names)
452                           (eq (class-name specl) class-names)))
453              (return m))))))
454    
455    (defmacro call-initialize-function (initialize-function instance initargs)
456      `(let ((.function. ,initialize-function))
457         (if (and (consp .function.)
458                  (eq (car .function.) 'call-initialize-instance-simple))
459             (initialize-instance-simple (cadr .function.) (caddr .function.)
460                                         ,instance ,initargs)
461             (funcall (the function .function.) ,instance ,initargs))))
462    
463    (defmacro copy-slots (slots-init)
464      #-(or lucid cmu17)
465      `(copy-seq ,slots-init)
466      #+(or lucid cmu17)
467      `(let* ((init ,slots-init)
468              (len (length init))
469              (v #+lucid (system:new-simple-vector len)
470                 #+cmu17 (lisp::allocate-vector #.vm:simple-vector-type len len)))
471         (declare (simple-vector init v)
472                  (type #-cmu fixnum #+cmu lisp::index len))
473         (dotimes (i len v)
474           (declare (type #-cmu fixnum #+cmu lisp::index i))
475           (setf (svref v i) (svref init i)))))
476    
477    (defmacro allocate-standard-instance--macro (wrapper slots-init)
478      #-new-kcl-wrapper
479      `(let ((instance (%%allocate-instance--class)))
480         (setf (std-instance-wrapper instance) ,wrapper)
481         (setf (std-instance-slots instance) (copy-slots ,slots-init))
482         instance)
483      #+new-kcl-wrapper
484      `(allocate-standard-instance ,wrapper ,slots-init))
485    
486    (defmacro with-make-instance-function-valid-p-check (initargs-form &body body)
487      `(let ((current-class (if class-cell
488                                (find-class-from-cell class-key class-cell)
489                                class-symbol)))
490         (if (or (not (eq current-class class-symbol))
491                 (invalid-wrapper-p wrapper))
492             (make-instance-function-trap current-class ,initargs-form)
493             (progn ,@body))))
494    
495    (defun make-instance-function-trap (class-symbol initargs)
496      (let* ((info (initialize-info class-symbol initargs))
497             (fn (initialize-info-make-instance-function info)))
498        (declare (type function fn))
499        (funcall fn class-symbol initargs)))
500    
501    (defun make-instance-function-simple (key class keys
502                                              initialize-instance-methods
503                                              shared-initialize-methods)
504      (let* ((class-key (car key))
505             (class-cell (when (symbolp class-key)
506                           (find-class-cell class-key nil)))
507             (wrapper (class-wrapper class))
508             (lwrapper (list wrapper))
509             (allocate-function
510              (cond ((structure-class-p class)
511                     #'allocate-structure-instance)
512                    ((standard-class-p class)
513                     #'allocate-standard-instance)
514                    ((funcallable-standard-class-p class)
515                     #'allocate-funcallable-instance)
516                    (t
517                     (error "error in make-instance-function-simple"))))
518             (allocate-macro
519              (cond ((standard-class-p class)
520                     'allocate-standard-instance--macro)))
521             (std-si-meth (find-standard-ii-method shared-initialize-methods
522                                                   'slot-object))
523             (shared-initfns
524              (nreverse (mapcar #'(lambda (method)
525                                    (make-effective-method-function
526                                     #'shared-initialize
527                                     `(call-method ,method nil)
528                                     nil lwrapper))
529                                (remove std-si-meth shared-initialize-methods))))
530             (std-ii-meth (find-standard-ii-method initialize-instance-methods
531                                                   'slot-object))
532             (initialize-initfns
533              (nreverse (mapcar #'(lambda (method)
534                                    (make-effective-method-function
535                                     #'initialize-instance
536                                     `(call-method ,method nil)
537                                     nil lwrapper))
538                                (remove std-ii-meth
539                                        initialize-instance-methods)))))
540        (multiple-value-bind (initialize-function constants)
541            (get-simple-initialization-function class keys (caddr key))
542          (if (eq allocate-macro 'allocate-standard-instance--macro)
543              #'(lambda (class-symbol &rest initargs)
544                  (with-make-instance-function-valid-p-check initargs
545                    (let ((instance
546                           (allocate-standard-instance--macro wrapper constants)))
547                      (call-initialize-function initialize-function instance initargs)
548                      (dolist (fn shared-initfns)
549                        (invoke-effective-method-function fn t instance t initargs))
550                      (dolist (fn initialize-initfns)
551                        (invoke-effective-method-function fn t instance initargs))
552                      instance)))
553              #'(lambda (class-symbol &rest initargs)
554                  (with-make-instance-function-valid-p-check initargs
555                    (let* ((instance (funcall allocate-function wrapper constants))
556                           (initargs (call-initialize-function initialize-function
557                                                               instance initargs)))
558                      (dolist (fn shared-initfns)
559                        (invoke-effective-method-function fn t instance t initargs))
560                      (dolist (fn initialize-initfns)
561                        (invoke-effective-method-function fn t instance initargs))
562                      instance)))))))
563    
564    (defun make-instance-function-complex (key class keys
565                                               initialize-instance-methods
566                                               shared-initialize-methods)
567      (multiple-value-bind (initargs-function initialize-function)
568          (get-complex-initialization-functions class keys (caddr key))
569        (let* ((class-key (car key))
570               (class-cell (when (symbolp class-key)
571                             (find-class-cell class-key nil)))
572               (wrapper (class-wrapper class))
573               (shared-initialize
574                (get-secondary-dispatch-function
575                 #'shared-initialize shared-initialize-methods
576                 `((class-eq ,class) t t)
577                 `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
578                    ,#'(lambda (instance init-type &rest initargs)
579                         (declare (ignore init-type))
580                         #+copy-&rest-arg (setq initargs (copy-list initargs))
581                         (call-initialize-function initialize-function
582                                                   instance initargs)
583                         instance)))
584                 (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
585               (initialize-instance
586                (get-secondary-dispatch-function
587                 #'initialize-instance initialize-instance-methods
588                 `((class-eq ,class) t)
589                 `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
590                    ,#'(lambda (instance &rest initargs)
591                         #+copy-&rest-arg (setq initargs (copy-list initargs))
592                         (invoke-effective-method-function
593                          shared-initialize t instance t initargs))))
594                 (list wrapper *the-wrapper-of-t*))))
595          #'(lambda (class-symbol &rest initargs)
596              (with-make-instance-function-valid-p-check initargs
597                (let* ((initargs (call-initialize-function initargs-function
598                                                           nil initargs))
599                       (instance (apply #'allocate-instance class initargs)))
600                  (invoke-effective-method-function
601                   initialize-instance t instance initargs)
602                  instance))))))
603    
604    #|
605    (defmacro call-initialize-function (initialize-function instance initargs)
606      `(let ((.function. ,initialize-function))
607         (if (and (consp .function.)
608                  (eq (car .function.) 'call-initialize-instance-simple))
609             (initialize-instance-simple (cadr .function.) (caddr .function.)
610                                         ,instance ,initargs)
611             (funcall (the function .function.) ,instance ,initargs))))
612    
613    (defun make-instance-function-basic (key class keys)
614      (let* ((class-key (car key))
615             (class-cell (find-class-cell class-key nil))
616             (wrapper (class-wrapper class)))
617        (multiple-value-bind (initialize-function constants)
618            (get-simple-initialization-function class keys (caddr key))
619          #'(lambda (class-symbol &rest initargs)
620              (let ((current-class (find-class-from-cell class-key class-cell)))
621                (if (or (not (eq current-class class-symbol))
622                        (invalid-wrapper-p wrapper))
623                    (make-instance-function-trap current-class initargs-form)
624                    (let ((instance
625                           (allocate-standard-instance--macro wrapper constants)))
626                      (call-initialize-function initialize-function instance initargs)
627                      instance)))))))
628    |#
629    
630    (defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
631      (let ((info (initialize-info class keys nil allow-other-keys-arg)))
632        (values (initialize-info-combined-initialize-function info)
633                (initialize-info-constants info))))
634    
635    (defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
636                                                       separate-p)
637      (let* ((info (initialize-info class keys nil allow-other-keys-arg))
638             (default-initargs-function (initialize-info-default-initargs-function info)))
639        (if separate-p
640            (values default-initargs-function
641                    (initialize-info-shared-initialize-t-function info))
642            (values default-initargs-function
643                    (initialize-info-shared-initialize-t-function
644                     (initialize-info class (initialize-info-new-keys info)
645                                      nil allow-other-keys-arg))))))
646    
647    (defun add-forms (forms forms-list)
648      (when forms
649        (setq forms (copy-list forms))
650        (if (null (car forms-list))
651            (setf (car forms-list) forms)
652            (setf (cddr forms-list) forms))
653        (setf (cdr forms-list) (last forms)))
654      (car forms-list))
655    
656    (defun make-default-initargs-form-list (class keys &optional (separate-p t))
657      (let ((initargs-form-list (cons nil nil))
658            (default-initargs (class-default-initargs class))
659            (nkeys keys)
660            (slots-alist
661             (mapcan #'(lambda (slot)
662                         (mapcar #'(lambda (arg)
663                                     (cons arg slot))
664                                 (slot-definition-initargs slot)))
665                     (class-slots class)))
666            (nslots nil))
667        (dolist (key nkeys)
668          (pushnew (cdr (assoc key slots-alist)) nslots))
669        (dolist (default default-initargs)
670          (let* ((key (car default))
671                 (slot (cdr (assoc key slots-alist)))
672                 (function (cadr default)))
673            (unless (member slot nslots)
674              (add-forms `((funcall ,function) (push-initarg ,key))
675                         initargs-form-list)
676              (push key nkeys)
677              (push slot nslots))))
678        (when separate-p
679          (add-forms `((update-initialize-info-cache
680                        ,class ,(initialize-info class nkeys nil)))
681                     initargs-form-list))
682        (add-forms `((finish-pushing-initargs))
683                   initargs-form-list)
684        (values (car initargs-form-list) nkeys)))
685    
686    (defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
687      (let* ((initialize-form-list (cons nil nil))
688             (type (cond ((structure-class-p class)
689                          'structure)
690                         ((standard-class-p class)
691                          'standard)
692                         ((funcallable-standard-class-p class)
693                          'funcallable)
694                         (t (error "error in make-shared-initialize-form-list"))))
695             (wrapper (class-wrapper class))
696             (constants (when simple-p
697                          (make-array (wrapper-no-of-instance-slots wrapper)
698                                      ':initial-element *slot-unbound*)))
699             (slots (class-slots class))
700             (slot-names (mapcar #'slot-definition-name slots))
701             (slots-key (mapcar #'(lambda (slot)
702                                    (let ((index most-positive-fixnum))
703                                      (dolist (key (slot-definition-initargs slot))
704                                        (let ((pos (position key keys)))
705                                          (when pos (setq index (min index pos)))))
706                                      (cons slot index)))
707                                slots))
708             (slots (stable-sort slots-key #'< :key #'cdr)))
709        (let ((n-popped 0))
710          (declare (fixnum n-popped))
711          (dolist (slot+index slots)
712            (let* ((slot (car slot+index))
713                   (name (slot-definition-name slot))
714                   (npop (1+ (- (the fixnum (cdr slot+index)) n-popped))))
715              (declare (fixnum npop))
716              (unless (eql (cdr slot+index) most-positive-fixnum)
717                (let* ((pv-offset (1+ (position name slot-names))))
718                  (add-forms `(,@(when (plusp npop)
719                                   `((pop-initargs ,(the fixnum (* 2 npop)))))
720                               (instance-set ,pv-offset ,slot))
721                             initialize-form-list))
722                (incf n-popped npop)))))
723        (dolist (slot+index slots)
724          (let* ((slot (car slot+index))
725                 (name (slot-definition-name slot)))
726            (when (and (eql (cdr slot+index) most-positive-fixnum)
727                       (or (eq si-slot-names 't)
728                           (member name si-slot-names)))
729              (let* ((initform (slot-definition-initform slot))
730                     (initfunction (slot-definition-initfunction slot))
731                     (location (unless (eq type 'structure)
732                                 (slot-definition-location slot)))
733                     (pv-offset (1+ (position name slot-names)))
734                     (forms (cond ((null initfunction)
735                                   nil)
736                                  ((constantp initform)
737                                   (let ((value (funcall initfunction)))
738                                     (if (and simple-p (integerp location))
739                                         (progn (setf (svref constants location) value)
740                                                nil)
741                                         `((const ,value)
742                                           (instance-set ,pv-offset ,slot)))))
743                                  (t
744                                   `((funcall ,(slot-definition-initfunction slot))
745                                     (instance-set ,pv-offset ,slot))))))
746                (add-forms `(,@(unless (or simple-p (null forms))
747                                 `((skip-when-instance-boundp ,pv-offset ,slot
748                                    ,(length forms))))
749                             ,@forms)
750                           initialize-form-list)))))
751        (values (car initialize-form-list) constants)))
752    
753    (defvar *class-pv-table-table* (make-hash-table :test 'eq))
754    
755    (defun get-pv-cell-for-class (class)
756      (let* ((slot-names (mapcar #'slot-definition-name (class-slots class)))
757             (slot-name-lists (list (cons nil slot-names)))
758             (pv-table (gethash class *class-pv-table-table*)))
759        (unless (and pv-table
760                     (equal slot-name-lists (pv-table-slot-name-lists pv-table)))
761          (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists))
762          (setf (gethash class *class-pv-table-table*) pv-table))
763        (pv-table-lookup pv-table (class-wrapper class))))    
764    
765    (defvar *initialize-instance-simple-alist* nil)
766    (defvar *note-iis-entry-p* nil)
767    
768    (defvar *compiled-initialize-instance-simple-functions*
769      (make-hash-table :test #'equal))
770    
771    (defun initialize-instance-simple-function (use info class form-list)
772      (let* ((pv-cell (get-pv-cell-for-class class))
773             (key (initialize-info-key info))
774             (sf-key (list* use (class-name (car key)) (cdr key))))
775        (if (or *compile-make-instance-functions-p*
776                (gethash sf-key *compiled-initialize-instance-simple-functions*))
777            (multiple-value-bind (form args)
778                (form-list-to-lisp pv-cell form-list)
779              (let ((entry (assoc form *initialize-instance-simple-alist*
780                                  :test #'equal)))
781                (setf (gethash sf-key
782                               *compiled-initialize-instance-simple-functions*)
783                      t)
784                (if entry
785                    (setf (cdddr entry) (union (list sf-key) (cdddr entry)
786                                               :test #'equal))
787                    (progn
788                      (setq entry (list* form nil nil (list sf-key)))
789                      (setq *initialize-instance-simple-alist*
790                            (nconc *initialize-instance-simple-alist*
791                                   (list entry)))))
792                (unless (or *note-iis-entry-p* (cadr entry))
793                  (setf (cadr entry) (compile-lambda (car entry))))
794                (if (cadr entry)
795                    (apply (the function (cadr entry)) args)
796                    `(call-initialize-instance-simple ,pv-cell ,form-list))))
797            #||
798            #'(lambda (instance initargs)
799                (initialize-instance-simple pv-cell form-list instance initargs))
800            ||#
801            `(call-initialize-instance-simple ,pv-cell ,form-list))))
802    
803    (defun load-precompiled-iis-entry (form function system uses)
804      (let ((entry (assoc form *initialize-instance-simple-alist*
805                          :test #'equal)))
806        (unless entry
807          (setq entry (list* form nil nil nil))
808          (setq *initialize-instance-simple-alist*
809                (nconc *initialize-instance-simple-alist*
810                       (list entry))))
811        (setf (cadr entry) function)
812        (setf (caddr entry) system)
813        (dolist (use uses)
814          (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
815        (setf (cdddr entry) (union uses (cdddr entry)
816                                   :test #'equal))))
817    
818    (defmacro precompile-iis-functions (&optional system)
819      (let ((index -1))
820        `(progn
821          ,@(gathering1 (collecting)
822             (dolist (iis-entry *initialize-instance-simple-alist*)
823               (when (or (null (caddr iis-entry))
824                         (eq (caddr iis-entry) system))
825                 (when system (setf (caddr iis-entry) system))
826                 (gather1
827                  (make-top-level-form
828                   `(precompile-initialize-instance-simple ,system ,(incf index))
829                   '(load)
830                   `(load-precompiled-iis-entry
831                     ',(car iis-entry)
832                     #',(car iis-entry)
833                     ',system
834                     ',(cdddr iis-entry))))))))))
835    
836    (defun compile-iis-functions (after-p)
837      (let ((*compile-make-instance-functions-p* t)
838            (*revert-initialize-info-p* t)
839            (*note-iis-entry-p* (not after-p)))
840        (declare (special *compile-make-instance-functions-p*))
841        (when (eq *boot-state* 'complete)
842          (update-make-instance-function-table))))
843    
844    
845    ;(const const)
846    ;(funcall function)
847    ;(push-initarg const)
848    ;(pop-supplied count) ; a positive odd number
849    ;(instance-set pv-offset slotd)
850    ;(skip-when-instance-boundp pv-offset slotd n)
851    
852    (defun initialize-instance-simple (pv-cell form-list instance initargs)
853      (let ((pv (car pv-cell))
854            (initargs-tail initargs)
855            (slots (get-slots-or-nil instance))
856            (class (class-of instance))
857            value)
858        (loop (when (null form-list) (return nil))
859              (let ((form (pop form-list)))
860                (ecase (car form)
861                  (push-initarg
862                   (push value initargs)
863                   (push (cadr form) initargs))
864                  (const
865                   (setq value (cadr form)))
866                  (funcall
867                   (setq value (funcall (the function (cadr form)))))
868                  (pop-initargs
869                   (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
870                   (setq value (pop initargs-tail)))
871                  (instance-set
872                   (instance-write-internal
873                    pv slots (cadr form) value
874                    (setf (slot-value-using-class class instance (caddr form)) value)))
875                  (skip-when-instance-boundp
876                   (when (instance-boundp-internal
877                          pv slots (cadr form)
878                          (slot-boundp-using-class class instance (caddr form)))
879                     (dotimes (i (cadddr form))
880                       (pop form-list))))
881                  (update-initialize-info-cache
882                   (when (consp initargs)
883                     (setq initargs (cons (car initargs) (cdr initargs))))
884                   (setq *initialize-info-cache-class* (cadr form))
885                   (setq *initialize-info-cache-initargs* initargs)
886                   (setq *initialize-info-cache-info* (caddr form)))
887                  (finish-pushing-initargs
888                   (setq initargs-tail initargs)))))
889        initargs))
890    
891    (defun add-to-cvector (cvector constant)
892      (or (position constant cvector)
893          (prog1 (fill-pointer cvector)
894            (vector-push-extend constant cvector))))
895    
896    (defvar *inline-iis-instance-locations-p* t)
897    
898    (defun first-form-to-lisp (forms cvector pv)
899      (flet ((const (constant)
900               (cond ((or (numberp constant) (characterp constant))
901                      constant)
902                     ((and (symbolp constant) (symbol-package constant))
903                      `',constant)
904                     (t
905                      `(svref cvector ,(add-to-cvector cvector constant))))))
906        (let ((form (pop (car forms))))
907          (ecase (car form)
908            (push-initarg
909             `((push value initargs)
910               (push ,(const (cadr form)) initargs)))
911            (const
912             `((setq value ,(const (cadr form)))))
913            (funcall
914             `((setq value (funcall (the function ,(const (cadr form)))))))
915            (pop-initargs
916             `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
917                                        (case pop
918                                          (1 `(cdr))
919                                          (3 `(cdddr))
920                                          (t `(nthcdr ,pop))))
921                                    initargs-tail))
922               (setq value (pop initargs-tail))))
923            (instance-set
924             (let* ((pv-offset (cadr form))
925                    (location (pvref pv pv-offset))
926                    (default `(setf (slot-value-using-class class instance
927                                                            ,(const (caddr form)))
928                                    value)))
929               (if *inline-iis-instance-locations-p*
930                   (typecase location
931                     (fixnum `((setf (%instance-ref slots ,(const location)) value)))
932                     (cons `((setf (cdr ,(const location)) value)))
933                     (t `(,default)))
934                   `((instance-write-internal pv slots ,(const pv-offset) value
935                      ,default
936                      ,(typecase location
937                         (fixnum ':instance)
938                         (cons ':class)
939                         (t ':default)))))))
940            (skip-when-instance-boundp
941             (let* ((pv-offset (cadr form))
942                    (location (pvref pv pv-offset))
943                    (default `(slot-boundp-using-class class instance
944                               ,(const (caddr form)))))
945               `((unless ,(if *inline-iis-instance-locations-p*
946                              (typecase location
947                                (fixnum `(not (eq (%instance-ref slots ,(const location))
948                                                  ',*slot-unbound*)))
949                                (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*)))
950                                (t default))
951                              `(instance-boundp-internal pv slots ,(const pv-offset)
952                                ,default
953                                ,(typecase (pvref pv pv-offset)
954                                   (fixnum ':instance)
955                                   (cons ':class)
956                                   (t ':default))))
957                   ,@(let ((sforms (cons nil nil)))
958                       (dotimes (i (cadddr form) (car sforms))
959                         (add-forms (first-form-to-lisp forms cvector pv) sforms)))))))
960            (update-initialize-info-cache
961             `((when (consp initargs)
962                 (setq initargs (cons (car initargs) (cdr initargs))))
963               (setq *initialize-info-cache-class* ,(const (cadr form)))
964               (setq *initialize-info-cache-initargs* initargs)
965               (setq *initialize-info-cache-info* ,(const (caddr form)))))
966            (finish-pushing-initargs
967             `((setq initargs-tail initargs)))))))
968    
969    (defmacro iis-body (&body forms)
970      (let ((vars '(initargs-tail pv slots wrapper class value)))
971        `(let ((initargs-tail initargs)
972               (pv (car pv-cell))
973               (slots nil)
974               (wrapper #+cmu17 (kernel:layout-of instance) #-cmu17 nil)
975               class
976               value)
977           ,@(progn
978              #-cmu vars
979              #+cmu `((declare (ignorable ,@vars))))
980           #+cmu17
981           (cond ((not (typep wrapper 'wrapper)))
982                 ((std-instance-p instance)
983                  (setq slots (std-instance-slots instance)))
984                 (t
985                  (setq slots (fsc-instance-slots instance))))
986           #-cmu17
987           (cond ((std-instance-p instance)
988                  (setq slots (std-instance-slots instance))
989                  (setq wrapper (std-instance-wrapper instance)))
990                 ((fsc-instance-p instance)
991                  (setq slots (fsc-instance-slots instance))
992                  (setq wrapper (fsc-instance-wrapper instance)))
993                 (t
994                  (setq wrapper (wrapper-of instance))))
995           (setq class (wrapper-class wrapper))
996           ,@forms)))
997    
998    (defun form-list-to-lisp (pv-cell form-list)
999      (let* ((forms (list form-list))
1000             (cvector (make-array (floor (length form-list) 2)
1001                                  :fill-pointer 0 :adjustable t))
1002             (pv (car pv-cell))
1003             (body (let ((rforms (cons nil nil)))
1004                     (loop (when (null (car forms)) (return (car rforms)))
1005                           (add-forms (first-form-to-lisp forms cvector pv)
1006                                      rforms))))
1007             (cvector-type `(simple-vector ,(length cvector))))
1008        (values
1009         `(lambda (pv-cell cvector)
1010            (declare (type ,cvector-type cvector))
1011            #+cmu
1012            (declare (ignorable pv-cell cvector))
1013            #'(lambda (instance initargs)
1014                (declare #.*optimize-speed*)
1015                #+cmu
1016                (declare (ignorable instance initargs))
1017                (iis-body ,@body)
1018                initargs))
1019         (list pv-cell (coerce cvector cvector-type)))))
1020    
1021    
1022    ;The effect of this is to cause almost all of the overhead of make-instance
1023    ;to happen at load time (or maybe at precompile time, as explained in a
1024    ;previous message) rather than the first time make-instance is called with
1025    ;a given class-name and sequence of keywords.  
1026    
1027    ;This optimization applys only when the first argument and all the even
1028    ;numbered arguments are constants evaluating to interned symbols.
1029    
1030    #+cmu
1031    (declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
1032    
1033    ; Use this definition in any CL implementation supporting
1034    ; both define-compiler-macro and load-time-value.
1035    #+cmu
1036    (define-compiler-macro make-instance (&whole form &rest args)
1037      (declare (ignore args))
1038      (let* ((*make-instance-function-keys* nil)
1039             (expanded-form (expand-make-instance-form form)))
1040        (if expanded-form
1041            `(funcall (the function
1042                           (symbol-function
1043                            ;; The symbol is guaranteed to be fbound.
1044                            ;; Is there a way to declare this?
1045                            (load-time-value
1046                             (get-make-instance-function-symbol
1047                              ',(first *make-instance-function-keys*)))))
1048                      ,@(cdr expanded-form))
1049            form)))
1050    
1051    (defun get-make-instance-function-symbol (key)
1052      (get-make-instance-functions (list key))
1053      (make-instance-function-symbol key))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26