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

Diff of /src/pcl/dlisp.lisp

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

revision 1.2.1.1 by ram, Tue Jul 20 19:02:25 1993 UTC revision 1.13 by rtoy, Fri Mar 19 15:19:03 2010 UTC
# Line 23  Line 23 
23  ;;;  ;;;
24  ;;; Suggestions, comments and requests for improvements are also welcome.  ;;; Suggestions, comments and requests for improvements are also welcome.
25  ;;; *************************************************************************  ;;; *************************************************************************
26    
27    (file-comment
28      "$Header$")
29  ;;;  ;;;
30    
31  (in-package :pcl)  (in-package :pcl)
32    (intl:textdomain "cmucl")
33    
34  ;;; This file is (almost) functionally equivalent to dlap.lisp,  ;;; This file is (almost) functionally equivalent to dlap.lisp,
35  ;;; but easier to read.  ;;; but easier to read.
# Line 36  Line 40 
40  (defun emit-one-class-reader (class-slot-p)  (defun emit-one-class-reader (class-slot-p)
41    (emit-reader/writer :reader 1 class-slot-p))    (emit-reader/writer :reader 1 class-slot-p))
42    
43    (defun emit-one-class-boundp (class-slot-p)
44      (emit-reader/writer :boundp 1 class-slot-p))
45    
46  (defun emit-one-class-writer (class-slot-p)  (defun emit-one-class-writer (class-slot-p)
47    (emit-reader/writer :writer 1 class-slot-p))    (emit-reader/writer :writer 1 class-slot-p))
48    
49  (defun emit-two-class-reader (class-slot-p)  (defun emit-two-class-reader (class-slot-p)
50    (emit-reader/writer :reader 2 class-slot-p))    (emit-reader/writer :reader 2 class-slot-p))
51    
52    (defun emit-two-class-boundp (class-slot-p)
53      (emit-reader/writer :boundp 2 class-slot-p))
54    
55  (defun emit-two-class-writer (class-slot-p)  (defun emit-two-class-writer (class-slot-p)
56    (emit-reader/writer :writer 2 class-slot-p))    (emit-reader/writer :writer 2 class-slot-p))
57    
# Line 50  Line 60 
60  (defun emit-one-index-readers (class-slot-p)  (defun emit-one-index-readers (class-slot-p)
61    (emit-one-or-n-index-reader/writer :reader nil class-slot-p))    (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
62    
63    (defun emit-one-index-boundps (class-slot-p)
64      (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
65    
66  (defun emit-one-index-writers (class-slot-p)  (defun emit-one-index-writers (class-slot-p)
67    (emit-one-or-n-index-reader/writer :writer nil class-slot-p))    (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
68    
69  (defun emit-n-n-readers ()  (defun emit-n-n-readers ()
70    (emit-one-or-n-index-reader/writer :reader t nil))    (emit-one-or-n-index-reader/writer :reader t nil))
71    
72    (defun emit-n-n-boundps ()
73      (emit-one-or-n-index-reader/writer :boundp t nil))
74    
75  (defun emit-n-n-writers ()  (defun emit-n-n-writers ()
76    (emit-one-or-n-index-reader/writer :writer t nil))    (emit-one-or-n-index-reader/writer :writer t nil))
77    
# Line 78  Line 94 
94  (defvar *precompiling-lap* nil)  (defvar *precompiling-lap* nil)
95  (defvar *emit-function-p* t)  (defvar *emit-function-p* t)
96    
97    (defvar *optimize-cache-functions-p* t)
98    
99  (defun emit-default-only (metatypes applyp)  (defun emit-default-only (metatypes applyp)
100    (when (and (null *precompiling-lap*) *emit-function-p*)    (unless *optimize-cache-functions-p*
101      (return-from emit-default-only      (when (and (null *precompiling-lap*) *emit-function-p*)
102        (emit-default-only-function metatypes applyp)))        (return-from emit-default-only
103            (emit-default-only-function metatypes applyp))))
104    (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))    (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
105           (args (remove '&rest dlap-lambda-list))           (args (remove '&rest dlap-lambda-list))
106           (restl (when applyp '(.lap-rest-arg.))))           (restl (when applyp '(.lap-rest-arg.))))
# Line 89  Line 108 
108                       dlap-lambda-list                       dlap-lambda-list
109        `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))        `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
110    
 (defmacro emit-default-only-macro (metatypes applyp)  
   (let ((*emit-function-p* nil)  
         (*precompiling-lap* t))  
     (values  
      (emit-default-only metatypes applyp))))  
   
111  ;;; --------------------------------  ;;; --------------------------------
112    
113  (defun generating-lisp (closure-variables args form)  (defun generating-lisp (closure-variables args form)
# Line 104  Line 117 
117           (lambda `(lambda ,closure-variables           (lambda `(lambda ,closure-variables
118                      ,@(when (member 'miss-fn closure-variables)                      ,@(when (member 'miss-fn closure-variables)
119                          `((declare (type function miss-fn))))                          `((declare (type function miss-fn))))
120                      #'(#+cmu kernel:instance-lambda #-cmu lambda ,args                      #'(kernel:instance-lambda ,args
121                          #+copy-&rest-arg                          ;;
122                          ,@(when rest                          ;; Don't ask me why LOCALLY is necessary here.
123                              `((setq .lap-rest-arg.                          ;; Fact is that without it the resulting code is
124                                      (copy-list .lap-rest-arg.))))                          ;; up ta 25% slower.  --gerd 2002-10-26.
125                          (let ()                          (locally (declare #.*optimize-speed*)
                           (declare #.*optimize-speed*)  
126                            ,form)))))                            ,form)))))
127      (values (if *precompiling-lap*      (values (if *precompiling-lap*
128                  `#',lambda                  `#',lambda
129                  (compile-lambda lambda))                  (compile-lambda lambda))
130              nil)))              nil)))
131    
132    ;;;
133  ;;; cmu17 note: since std-instance-p is weakened, that branch may run  ;;; cmu17 note: since std-instance-p is weakened, that branch may run
134  ;;; on non-pcl instances (structures).  The result will be the  ;;; on non-pcl instances (structures).  The result will be the
135  ;;; non-wrapper layout for the structure, which will cause a miss.  The "slots"  ;;; non-wrapper layout for the structure, which will cause a miss.
136  ;;; will be whatever the first slot is, but will be ignored.  Similarly,  ;;; The "slots" will be whatever the first slot is, but will be
137  ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.  ;;; ignored.  Similarly, fsc-instance-p returns true on funcallable
138    ;;; structures as well as PCL fins.
139  ;;;  ;;;
140  (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)  (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
141    (when (and (null *precompiling-lap*) *emit-function-p*)    (unless *optimize-cache-functions-p*
142      (return-from emit-reader/writer      (when (and (null *precompiling-lap*) *emit-function-p*)
143        (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))        (return-from emit-reader/writer
144    (let ((instance nil)          (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p))))
145          (arglist  ())    (let* ((instance
146          (closure-variables ())            (ecase reader/writer
147          (field (first-wrapper-cache-number-index))              ((:reader :boundp) (dfun-arg-symbol 0))
148          (readp (eq reader/writer :reader))              (:writer (dfun-arg-symbol 1))))
149          (read-form (emit-slot-read-form class-slot-p 'index 'slots)))           (arglist
150      ;;we need some field to do the fast obsolete check            (ecase reader/writer
151      (ecase reader/writer              ((:reader :boundp) (list instance))
152        (:reader (setq instance (dfun-arg-symbol 0)              (:writer (list (dfun-arg-symbol 0) instance))))
153                       arglist  (list instance)))           (closure-variables
154        (:writer (setq instance (dfun-arg-symbol 1)            (ecase 1-or-2-class
155                       arglist  (list (dfun-arg-symbol 0) instance))))              (1 '(wrapper-0 index miss-fn))
156      (ecase 1-or-2-class              (2 '(wrapper-0 wrapper-1 index miss-fn))))
157        (1 (setq closure-variables '(wrapper-0 index miss-fn)))           (read-form
158        (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))            (emit-slot-read-form class-slot-p 'index 'slots)))
159      (generating-lisp closure-variables      (generating-lisp closure-variables arglist
                      arglist  
160         `(let* (,@(unless class-slot-p `((slots nil)))         `(let* (,@(unless class-slot-p `((slots nil)))
161                 (wrapper (cond ((std-instance-p ,instance)                 (wrapper (cond ((std-instance-p ,instance)
162                                 ,@(unless class-slot-p                                 ,@(unless class-slot-p
# Line 152  Line 165 
165                                ((fsc-instance-p ,instance)                                ((fsc-instance-p ,instance)
166                                 ,@(unless class-slot-p                                 ,@(unless class-slot-p
167                                     `((setq slots (fsc-instance-slots ,instance))))                                     `((setq slots (fsc-instance-slots ,instance))))
168                                 (fsc-instance-wrapper ,instance))))                                 (fsc-instance-wrapper ,instance)))))
169                 ,@(when readp '(value)))            (block access
170            (if (or (null wrapper)              (when (and wrapper
171                    (zerop (wrapper-cache-number-vector-ref wrapper ,field))                         (not (zerop (kernel:layout-hash wrapper 0)))
172                    (not (or (eq wrapper wrapper-0)                         ,@(if (eql 1 1-or-2-class)
173                             ,@(when (eql 2 1-or-2-class)                               `((eq wrapper wrapper-0))
174                                 `((eq wrapper wrapper-1)))))                               `((or (eq wrapper wrapper-0)
175                    ,@(when readp `((eq *slot-unbound* (setq value ,read-form)))))                                     (eq wrapper wrapper-1)))))
176                (funcall miss-fn ,@arglist)                ,@(ecase reader/writer
177                ,(if readp                   (:reader
178                     'value                    `((let ((value ,read-form))
179                     `(setf ,read-form ,(car arglist))))))))                        (unless (eq value +slot-unbound+)
180                            (return-from access value)))))
181                     (:boundp
182                      `((let ((value ,read-form))
183                          (return-from access (not (eq value +slot-unbound+))))))
184                     (:writer
185                      `((return-from access (setf ,read-form ,(car arglist)))))))
186                (funcall miss-fn ,@arglist))))))
187    
188  (defun emit-slot-read-form (class-slot-p index slots)  (defun emit-slot-read-form (class-slot-p index slots)
189    (if class-slot-p    (if class-slot-p
190        `(cdr ,index)        `(cdr ,index)
191        `(%instance-ref ,slots ,index)))        `(%slot-ref ,slots ,index)))
192    
193  (defun emit-boundp-check (value-form miss-fn arglist)  (defun emit-boundp-check (value-form miss-fn arglist)
194    `(let ((value ,value-form))    `(let ((value ,value-form))
195       (if (eq value *slot-unbound*)       (if (eq value +slot-unbound+)
196           (funcall ,miss-fn ,@arglist)           (funcall ,miss-fn ,@arglist)
197           value)))           value)))
198    
# Line 180  Line 200 
200    (let ((read-form (emit-slot-read-form class-slot-p index slots)))    (let ((read-form (emit-slot-read-form class-slot-p index slots)))
201      (ecase reader/writer      (ecase reader/writer
202        (:reader (emit-boundp-check read-form miss-fn arglist))        (:reader (emit-boundp-check read-form miss-fn arglist))
203          (:boundp `(not (eq +slot-unbound+ ,read-form)))
204        (:writer `(setf ,read-form ,(car arglist))))))        (:writer `(setf ,read-form ,(car arglist))))))
205    
206  (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)  (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
# Line 189  Line 210 
210       (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))       (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
211    
212  (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)  (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
213    (when (and (null *precompiling-lap*) *emit-function-p*)    (unless *optimize-cache-functions-p*
214      (return-from emit-one-or-n-index-reader/writer      (when (and (null *precompiling-lap*) *emit-function-p*)
215        (emit-one-or-n-index-reader/writer-function        (return-from emit-one-or-n-index-reader/writer
216         reader/writer cached-index-p class-slot-p)))          (emit-one-or-n-index-reader/writer-function
217             reader/writer cached-index-p class-slot-p))))
218    (multiple-value-bind (arglist metatypes)    (multiple-value-bind (arglist metatypes)
219        (ecase reader/writer        (ecase reader/writer
220          (:reader (values (list (dfun-arg-symbol 0))          ((:reader :boundp)
221                           '(standard-instance)))           (values (list (dfun-arg-symbol 0))
222          (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))                   '(standard-instance)))
223                           '(t standard-instance))))          (:writer
224             (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
225                     '(t standard-instance))))
226      (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)      (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
227                       arglist                       arglist
228        `(let (,@(unless class-slot-p '(slots))        `(let (,@(unless class-slot-p '(slots))
# Line 215  Line 239 
239    (let ((*emit-function-p* nil)    (let ((*emit-function-p* nil)
240          (*precompiling-lap* t))          (*precompiling-lap* t))
241      (values      (values
242       (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))       (emit-one-or-n-index-reader/writer reader/writer cached-index-p
243                                            class-slot-p))))
244    
245  (defun emit-miss (miss-fn args &optional applyp)  (defun emit-miss (miss-fn args &optional applyp)
246    (let ((restl (when applyp '(.lap-rest-arg.))))    (let ((restl (when applyp '(.lap-rest-arg.))))
# Line 224  Line 249 
249          `(funcall ,miss-fn ,@args ,@restl))))          `(funcall ,miss-fn ,@args ,@restl))))
250    
251  (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)  (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
252    (when (and (null *precompiling-lap*) *emit-function-p*)    (unless *optimize-cache-functions-p*
253      (return-from emit-checking-or-caching      (when (and (null *precompiling-lap*) *emit-function-p*)
254        (emit-checking-or-caching-function        (return-from emit-checking-or-caching
255         cached-emf-p return-value-p metatypes applyp)))          (emit-checking-or-caching-function
256             cached-emf-p return-value-p metatypes applyp))))
257    (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))    (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
258           (args (remove '&rest dlap-lambda-list))           (args (remove '&rest dlap-lambda-list))
259           (restl (when applyp '(.lap-rest-arg.))))           (restl (when applyp '(.lap-rest-arg.))))
# Line 243  Line 269 
269                       (emit-miss 'miss-fn args applyp)                       (emit-miss 'miss-fn args applyp)
270                       (when cached-emf-p 'emf))))))                       (when cached-emf-p 'emf))))))
271    
 (defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)  
   (let ((*emit-function-p* nil)  
         (*precompiling-lap* t))  
     (values  
      (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))  
   
272  (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)  (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
273    (let* ((index -1)    (let* ((index -1)
274           (wrapper-bindings (mapcan #'(lambda (arg mt)           (wrapper-bindings (mapcan (lambda (arg mt)
275                                         (unless (eq mt 't)                                       (unless (eq mt t)
276                                           (incf index)                                         (incf index)
277                                           `((,(intern (format nil "WRAPPER-~D" index)                                         `((,(intern (format nil "WRAPPER-~D" index)
278                                                       *the-pcl-package*)                                                     *the-pcl-package*)
279                                              ,(emit-fetch-wrapper mt arg 'miss                                            ,(emit-fetch-wrapper mt arg 'miss
280                                                (pop slot-regs))))))                                                                 (pop slot-regs))))))
281                                     args metatypes))                                     args metatypes))
282           (wrappers (mapcar #'car wrapper-bindings)))           (wrappers (mapcar #'car wrapper-bindings)))
283      (declare (fixnum index))      (declare (fixnum index))
284      (unless wrappers (error "Every metatype is T."))      (assert (not (null wrappers)) () _"Every metatype is T.")
285      `(block dfun      `(block dfun
286         (tagbody         (tagbody
287            (let ((field (cache-field cache))            (let ((field (cache-field cache))
# Line 299  Line 319 
319    
320  (defmacro get-cache-vector-lock-count (cache-vector)  (defmacro get-cache-vector-lock-count (cache-vector)
321    `(let ((lock-count (cache-vector-lock-count ,cache-vector)))    `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
      (unless (typep lock-count 'fixnum)  
        (error "my cache got freed somehow"))  
322       (the fixnum lock-count)))       (the fixnum lock-count)))
323    
324  (defun emit-1-t-dlap (wrapper miss-label value)  (defun emit-1-t-dlap (wrapper miss-label value)
# Line 334  Line 352 
352         ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)         ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
353         (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))         (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
354           (declare (fixnum initial-lock-count))           (declare (fixnum initial-lock-count))
355           (let ((location primary) (next-location 0))           (let ((location primary))
356             (declare (fixnum location next-location))             (declare (fixnum location))
357             (block search             (block search
358               (loop (setq next-location (the fixnum (+ location ,cache-line-size)))               (loop
359                     (when (and ,@(mapcar                  (let ((next-location (the fixnum (+ location ,cache-line-size))))
360                                   #'(lambda (wrapper)                    (declare #.*optimize-speed*)
361                                       `(eq ,wrapper                    (declare (fixnum next-location))
362                                         (cache-vector-ref cache-vector                    (when (and ,@(mapcar
363                                          (setq location                                  (lambda (wrapper)
364                                           (the fixnum (+ location 1))))))                                    `(eq ,wrapper
365                                   wrappers))                                         (%svref cache-vector
366                                                   (setq location
367                                                         (the fixnum (1+ location))))))
368                                    wrappers))
369                       ,@(when value                       ,@(when value
370                           `((setq location (the fixnum (+ location 1)))                           `((setq location (the fixnum (1+ location)))
371                             (setq ,value (cache-vector-ref cache-vector location))))                             (setq ,value (%svref cache-vector location))))
372                       (return-from search nil))                       (return-from search nil))
373                     (setq location next-location)                    (setq location next-location)
374                     (when (= location size-1)                    (when (= location size-1)
375                       (setq location 0))                      (setq location 0))
376                     (when (= location primary)                    (when (= location primary)
377                       (dolist (entry overflow)                      (loop for (ws . v) in overflow
378                         (let ((entry-wrappers (car entry)))                            when (and ,@(mapcar (lambda (w)
379                           (when (and ,@(mapcar #'(lambda (wrapper)                                                  `(eq ,w (pop ws)))
380                                                    `(eq ,wrapper (pop entry-wrappers)))                                                wrappers)) do
381                                                wrappers))                              ,@(when value `((setq ,value v)))
382                             ,@(when value                              (return-from search nil))
383                                 `((setq ,value (cdr entry))))                      (go ,miss-label)))))
                            (return-from search nil))))  
                      (go ,miss-label))))  
384             (unless (= initial-lock-count             (unless (= initial-lock-count
385                        (get-cache-vector-lock-count cache-vector))                        (get-cache-vector-lock-count cache-vector))
386               (go ,miss-label)))))))               (go ,miss-label)))))))
387    
388  (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)  (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
389    `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))    `(let ((wrapper-cache-no (kernel:layout-hash ,wrapper field)))
390       (declare (fixnum wrapper-cache-no))       (declare (fixnum wrapper-cache-no))
391       (when (zerop wrapper-cache-no) (go ,miss-label))       (when (zerop wrapper-cache-no)
392       ,(let ((form `(#+lucid %logand #-lucid logand         (go ,miss-label))
393                      mask wrapper-cache-no)))       ,(let ((form `(logand mask wrapper-cache-no)))
394          #+lucid form          `(the fixnum ,form))))
         #-lucid `(the fixnum ,form))))  
395    
396    #-pcl-xorhash
397  (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)  (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
398    (declare (type list wrappers))    (declare (type list wrappers))
399    ;; this returns 1 less that the actual location    ;; this returns 1 less that the actual location
400    `(progn    `(progn
401       ,@(let ((adds 0) (len (length wrappers)))       ,@(let ((adds 0) (len (length wrappers)))
402           (declare (fixnum adds len))           (declare (fixnum adds len))
403           (mapcar #'(lambda (wrapper)           (mapcar (lambda (wrapper)
404                       `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref                     `(let ((wrapper-cache-no (kernel:layout-hash ,wrapper field)))
405                                                 ,wrapper field)))                       (declare (fixnum wrapper-cache-no))
406                          (declare (fixnum wrapper-cache-no))                       (when (zerop wrapper-cache-no) (go ,miss-label))
407                          (when (zerop wrapper-cache-no) (go ,miss-label))                       (setq primary (the fixnum (+ primary wrapper-cache-no)))
408                          (setq primary (the fixnum (+ primary wrapper-cache-no)))                       ,@(progn
409                          ,@(progn                          (incf adds)
410                              (incf adds)                          (when (or (zerop (mod adds +max-hash-code-additions+))
411                              (when (or (zerop (mod adds wrapper-cache-number-adds-ok))                                    (eql adds len))
412                                        (eql adds len))                            `((setq primary
413                                `((setq primary                               ,(let ((form `(logand primary mask)))
414                                        ,(let ((form `(#+lucid %logand #-lucid logand                                     `(the fixnum ,form))))))))
                                                      primary mask)))  
                                          #+lucid form  
                                          #-lucid `(the fixnum ,form))))))))  
415                   wrappers))))                   wrappers))))
416    
417    #+pcl-xorhash
418    (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
419      (declare (type list wrappers))
420      ;; this returns 1 less that the actual location
421      `(progn
422         ,@(let ((adds 0) (len (length wrappers)))
423             (declare (fixnum adds len))
424             (mapcar (lambda (wrapper)
425                       `(let ((hash (kernel:layout-hash ,wrapper field)))
426                         (declare (fixnum hash))
427                         (when (zerop hash) (go ,miss-label))
428                         (setq primary (logxor primary hash))
429                         ,@(progn
430                            (incf adds)
431                            (when (eql adds len)
432                              `((setq primary
433                                 ,(let ((form `(logand primary mask)))
434                                       `(the fixnum ,form))))))))
435                     wrappers))))
436    
437    ;;;
438  ;;; cmu17 note: since std-instance-p is weakened, that branch may run  ;;; cmu17 note: since std-instance-p is weakened, that branch may run
439  ;;; on non-pcl instances (structures).  The result will be the  ;;; on non-pcl instances (structures).  The result will be the
440  ;;; non-wrapper layout for the structure, which will cause a miss.  The "slots"  ;;; non-wrapper layout for the structure, which will cause a miss.  The "slots"
# Line 406  Line 443 
443  ;;;  ;;;
444  (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)  (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
445    (ecase metatype    (ecase metatype
446      ((standard-instance #+new-kcl-wrapper structure-instance)      ((standard-instance)
447       `(cond ((std-instance-p ,argument)       `(cond ((std-instance-p ,argument)
448               ,@(when slot `((setq ,slot (std-instance-slots ,argument))))               ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
449               (std-instance-wrapper ,argument))               (std-instance-wrapper ,argument))
# Line 416  Line 453 
453              (t              (t
454               (go ,miss-label))))               (go ,miss-label))))
455      (class      (class
456       (when slot (error "Can't do a slot reg for this metatype."))       (assert (null slot) () _"Can't do a slot reg for this metatype.")
457       `(wrapper-of-macro ,argument))       `(wrapper-of-macro ,argument))
458      ((built-in-instance #-new-kcl-wrapper structure-instance)      ((built-in-instance structure-instance)
459       (when slot (error "Can't do a slot reg for this metatype."))       (assert (null slot) () _"Can't do a slot reg for this metatype.")
460       `(#+new-kcl-wrapper built-in-wrapper-of       `(built-in-or-structure-wrapper ,argument))))
        #-new-kcl-wrapper built-in-or-structure-wrapper  
        ,argument))))  
461    

Legend:
Removed from v.1.2.1.1  
changed lines
  Added in v.1.13

  ViewVC Help
Powered by ViewVC 1.1.5