Changeset 11410
- Timestamp:
- Nov 19, 2008, 2:32:53 AM (12 years ago)
- Location:
- branches/working-0711/ccl/level-1
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/level-1/l1-clos-boot.lisp
r11074 r11410 1318 1318 (find-class name errorp environment))))) 1319 1319 1320 (fset 'pessimize-make-instance-for-class-name ;; redefined later 1321 (qlfun bootstrapping-pessimize-make-instance-for-class-name (name) name)) 1322 1320 1323 (defun update-class-proper-names (name old-class new-class) 1324 (when name 1325 (pessimize-make-instance-for-class-name name)) 1321 1326 (when (and old-class 1322 1327 (not (eq old-class new-class)) -
branches/working-0711/ccl/level-1/l1-clos.lisp
r11400 r11410 309 309 (pushnew gf (gethash class *optimized-dependents*))) 310 310 311 ;; Yeah, yeah, when/if this gets more general can use generic functions.312 311 (defun unoptimize-dependents (class) 312 (pessimize-make-instance-for-class-name (%class-name class)) 313 313 (loop for obj in (gethash class *optimized-dependents*) 314 314 do (etypecase obj 315 (standard-generic-function (compute-dcode obj))))) 315 (standard-generic-function 316 (clear-gf-dispatch-table (%gf-dispatch-table obj)) 317 (compute-dcode obj))))) 316 318 317 319 (defun update-slots (class eslotds) … … 332 334 old-wrapper) 333 335 (t 336 (unoptimize-dependents class) 334 337 (make-instances-obsolete class) 335 338 (%cons-wrapper class))))) 336 (when old-wrapper337 (unoptimize-dependents class))338 339 (setf (%class-slots class) eslotds) 339 340 (setf (%wrapper-instance-slots new-wrapper) new-ordering … … 794 795 (let ((cell (find-class-cell class-name nil))) 795 796 (when cell 796 (setf (class-cell-instantiate cell) '%make-instance)))) 797 (init-class-cell-instantiator cell)))) 798 799 (defun init-class-cell-instantiator (cell) 800 (when cell 801 (setf (class-cell-instantiate cell) '%make-instance) 802 (setf (class-cell-extra cell) nil))) 797 803 798 804 ;;; Redefine an existing (not forward-referenced) class. … … 802 808 (unless (eq (class-of class) metaclass) 803 809 (error "Can't change metaclass of ~s to ~s." class metaclass)) 804 (pessimize-make-instance-for-class-name name)805 810 (apply #'reinitialize-instance class initargs) 806 811 (setf (find-class name) class))) … … 808 813 809 814 (defun ensure-class (name &rest keys &key &allow-other-keys) 810 (declare (special *sealed-clos-world*)) 811 (if *sealed-clos-world* 812 (error "Class (re)definition is not allowed in this environment") 813 (apply #'ensure-class-using-class (find-class name nil) name keys))) 815 (declare (dynamic-extent keys)) 816 (apply #'ensure-class-using-class (find-class name nil) name keys)) 814 817 815 818 (defparameter *defclass-redefines-improperly-named-classes-pedantically* … … 821 824 822 825 (defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys) 823 (declare (special *sealed-clos-world*)) 824 (if *sealed-clos-world* 825 (error "Class (re)definition is not allowed in this environment") 826 (progn 827 (record-source-file name 'class) 828 ;; Maybe record source-file information for accessors as well 829 ;; We should probably record them as "accessors of the class", since 830 ;; there won't be any other explicit defining form associated with 831 ;; them. 832 (let* ((existing-class (find-class name nil))) 833 (when (and *defclass-redefines-improperly-named-classes-pedantically* 834 existing-class 835 (not (eq (class-name existing-class) name))) 836 ;; Class isn't properly named; act like it didn't exist 837 (setq existing-class nil)) 838 (apply #'ensure-class-using-class existing-class name keys))))) 826 (declare (dynamic-extent keys)) 827 (record-source-file name 'class) 828 (let* ((existing-class (find-class name nil))) 829 (when (and *defclass-redefines-improperly-named-classes-pedantically* 830 existing-class 831 (not (eq (class-name existing-class) name))) 832 ;; Class isn't properly named; act like it didn't exist 833 (setq existing-class nil)) 834 (apply #'ensure-class-using-class existing-class name keys))) 839 835 840 836 … … 2371 2367 2372 2368 (defun optimize-make-instance-for-class-cell (cell) 2373 ( setf (class-cell-instantiate cell) '%make-instance)2369 (init-class-cell-instantiator cell) 2374 2370 (let* ((lambda (make-instantiate-lambda-for-class-cell cell))) 2375 2371 (when lambda … … 2397 2393 (eq gfn #'initialize-instance) 2398 2394 (eq gfn #'shared-initialize)) 2399 (let* ((specializer (car (method-specializers method))) 2400 (cell (and (typep specializer 'class) 2401 (gethash (class-name specializer) %find-classes%)))) 2402 (when cell 2403 (setf (class-cell-instantiate cell) '%make-instance))))) 2395 (let ((specializer (car (method-specializers method)))) 2396 (when (typep specializer 'class) 2397 (labels ((clear (class) 2398 (pessimize-make-instance-for-class-name (class-name class)) 2399 (dolist (sub (%class-direct-subclasses class)) 2400 (clear sub)))) 2401 (clear specializer)))))) 2404 2402 2405 2403 ;;; Iterate over all known GFs; try to optimize their dcode in cases … … 2410 2408 (optimize-make-instance t)) 2411 2409 (declare (ignore check-conflicts) 2412 (special *sealed-clos-world*)) 2413 (unless known-sealed-world 2414 (cerror "Proceed, if it's known that no new classes or methods will be defined." 2415 "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined.")) 2410 (ignore known-sealed-world)) 2416 2411 (when optimize-make-instance 2417 2412 (optimize-named-class-make-instance-methods)) … … 2422 2417 (when (%snap-reader-method f) 2423 2418 (incf nwin))) 2424 (setq *sealed-clos-world* t)2425 2419 (values ngf nwin 0))) 2426 2420 … … 2437 2431 2438 2432 (defun pessimize-clos () 2439 (declare (special *sealed-clos-world*)) 2440 (when *sealed-clos-world* 2441 ;; Undo MAKE-INSTANCE optimization 2442 (maphash (lambda (class-name class-cell) 2443 (declare (ignore class-name)) 2444 (setf (class-cell-instantiate class-cell) '%make-instance)) 2445 %find-classes%) 2446 ;; Un-snap reader methods, undo other GF optimizations. 2447 (dolist (f (population-data %all-gfs%)) 2448 (let* ((dt (%gf-dispatch-table f))) 2449 (clear-gf-dispatch-table dt) 2450 (compute-dcode f))) 2451 (setq *sealed-clos-world* nil) 2452 t)) 2433 ;; Undo MAKE-INSTANCE optimization 2434 (maphash (lambda (class-name class-cell) 2435 (declare (ignore class-name)) 2436 (init-class-cell-instantiator class-cell)) 2437 %find-classes%) 2438 ;; Un-snap reader methods, undo other GF optimizations. 2439 (dolist (f (population-data %all-gfs%)) 2440 (let* ((dt (%gf-dispatch-table f))) 2441 (clear-gf-dispatch-table dt) 2442 (compute-dcode f)))) 2453 2443 2454 2444 ;;; If there's a single method (with standard method combination) on
Note: See TracChangeset
for help on using the changeset viewer.