Changeset 8394

Timestamp:

Feb 2, 2008, 7:13:49 AM (17 years ago)

Author:

Bill St. Clair

Message:

Make the generic-function dispatch optimizations safe for development.

Make Marco's source-location change compile itself without error.

Eliminate duplicate bootstrapping definitions. Marco put them there so
that the new sources would compile in an old image. Now they won't,
but if you evaluate the following forms in an r8388 image, then you
can compile the new source.

(in-package :ccl)
(update-modules '(lispequ) t)
(in-development-mode

(defun read-internal (stream &optional eof-error-p eof-value recursive-p)

(setq stream (input-stream-arg stream))
(if recursive-p

(%read-form stream 0 nil)
(let ((%read-objects% nil) (%keep-whitespace% nil))

(%read-form stream (if eof-error-p 0) eof-value))))

(defun %compile-time-eval (form env)

(let* ((*target-backend* *host-backend*))

;; The HANDLER-BIND here is supposed to note WARNINGs that're
;; signaled during (eval-when (:compile-toplevel) processing; this
;; in turn is supposed to satisfy a pedantic interpretation of the
;; spec's requirement that COMPILE-FILE's second and third return
;; values reflect (all) conditions "detected by the compiler."
;; (It's kind of sad that CL language design is influenced so
;; strongly by the views of pedants these days.)
(handler-bind ((warning (lambda (c)

(setq *fasl-warnings-signalled-p* t)
(unless (typep c 'style-warning)

(setq *fasl-non-style-warnings-signalled-p* t))

(signal c))))

(funcall (compile-named-function

`(lambda () ,form)
:env env
:policy *compile-time-evaluation-policy*)))))

)

(in-package :cl-user)

level-1/l1-clos.lisp
====================
%snap-reader-methods marks the generic function dispatch tables it
clobbers as non-normal by setting %gf-dispatch-table-argnum to -1.

New function, maybe-remove-make-instance-optimization, undoes the
optimization installed by optimize-make-instance-for-class-cell, if
necessary because a new method may conflict. It needs to be undone for some
redefinitions of the class as well, but I haven't done that yet.

level-1/l1-clos-boot.lisp
=========================
Bootstrapping version of maybe-remove-make-instance-optimization.

%add-standard-method-to-standard-gf calls maybe-remove-make-instance-optimization.

remove-obsoleted-combined-methods does nothing if %gf-dispatch-table-argunum
is negative.

lib/nfcomp.lisp
===============
Remove duplicate read-internal definition.

compiler/nx.lisp
================
Remove duplicate %compile-time-eval definition

compiler/lambda-list.lisp
=========================
Remove duplicate $lfbits-info-bit definition

compiler/nx0.lisp
=================
record-source-location returns nil instead of signalling an error.

Location:

branches/source-tracking-0801/ccl

Files:

• compiler/lambda-list.lisp (modified) (1 diff)
• compiler/nx.lisp (modified) (1 diff)
• compiler/nx0.lisp (modified) (1 diff)
• level-1/l1-clos-boot.lisp (modified) (3 diffs)
• level-1/l1-clos.lisp (modified) (2 diffs)
• lib/nfcomp.lisp (modified) (1 diff)

branches/source-tracking-0801/ccl/compiler/lambda-list.lisp

@@ -20 +20 @@
 
 ;;; Compiler functions needed elsewhere
-
-;;; mb: HACK HACK HACKITY HACK
-(defconstant $lfbits-info-bit 23)
 
 (defun %lfun-info-index (fn)

branches/source-tracking-0801/ccl/compiler/nx.lisp

@@ -203 +203 @@
 (provide 'nx)
 
-;;; mb: HACK HACK HACKITY HACK
-
-(defun %compile-time-eval (form env)
-  (let* ((*target-backend* *host-backend*))
-    ;; The HANDLER-BIND here is supposed to note WARNINGs that're
-    ;; signaled during (eval-when (:compile-toplevel) processing; this
-    ;; in turn is supposed to satisfy a pedantic interpretation of the
-    ;; spec's requirement that COMPILE-FILE's second and third return
-    ;; values reflect (all) conditions "detected by the compiler."
-    ;; (It's kind of sad that CL language design is influenced so
-    ;; strongly by the views of pedants these days.)
-    (handler-bind ((warning (lambda (c)
-                              (setq *fasl-warnings-signalled-p* t)
-                              (unless (typep c 'style-warning)
-                                (setq *fasl-non-style-warnings-signalled-p* t))
-                              (signal c))))
-      (funcall (compile-named-function
-                `(lambda () ,form)
-                :env env
-                :policy *compile-time-evaluation-policy*)))))
-
 (defun define-compile-time-macro (name lambda-expression env)
   (let ((definition-env (definition-environment env)))

branches/source-tracking-0801/ccl/compiler/nx0.lisp

@@ -1594 +1594 @@
 
 (defun record-source-location (stream)
-  (if (and *compiler-record-source* *fcomp-stream*)
-      (if (eq *fcomp-stream* stream)
-          t
-          (progn
-            ;; if we don't set *compiler-record-source* to NIL here all subsequent calls to read in
-            ;; the debugger will fail. that would be bad.
-            (setf *compiler-record-source* nil)
-            (error "Attempting to record source on stream ~S but *fcomp-stream* is ~S."
-                   stream *fcomp-stream*)))
-      nil))
+  (and *compiler-record-source*
+       *fcomp-stream*
+       (eq *fcomp-stream* stream)))
 
 (defstruct (source-note (:constructor %make-source-note))

branches/source-tracking-0801/ccl/level-1/l1-clos-boot.lisp

@@ -835 +835 @@
   (%add-standard-method-to-standard-gf gf method))
 
+;; Redefined in l1-clos.lisp
+(defun maybe-remove-make-instance-optimization (gfn method)
+  (declare (ignore gfn method))
+  nil)
+
 (defun %add-standard-method-to-standard-gf (gfn method)
   (when (%method-gf method)
@@ -844 +849 @@
          (qualifiers (%method-qualifiers method)))
     (remove-obsoleted-combined-methods method dt specializers)
+    (maybe-remove-make-instance-optimization gfn method)
     (apply #'invalidate-initargs-vector-for-gf gfn specializers)
     (dolist (m methods)
@@ -962 +968 @@
    (when dt
      (if specializers
-       (let* ((argnum (%gf-dispatch-table-argnum dt))
-              (class (nth argnum specializers))
-              (size (%gf-dispatch-table-size dt))
-              (index 0))
-         (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
-         (if (typep class 'eql-specializer)
-           (setq class (class-of (eql-specializer-object class))))
-         (while (%i< index size)
-           (let* ((wrapper (%gf-dispatch-table-ref dt index))
-                  hash-index-0?
-                  (cpl (and wrapper
-                            (not (setq hash-index-0?
-                                       (eql 0 (%wrapper-hash-index wrapper))))
-                            (%inited-class-cpl
-                             (require-type (%wrapper-class wrapper) 'class)))))
-             (when (or hash-index-0? (and cpl (cpl-index class cpl)))
-               (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
-                     (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
-             (setq index (%i+ index 2)))))
+       (let* ((argnum (%gf-dispatch-table-argnum dt)))
+         (when (>= argnum 0)
+           (let ((class (nth argnum specializers))
+                 (size (%gf-dispatch-table-size dt))
+                 (index 0))
+             (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
+             (if (typep class 'eql-specializer)
+                 (setq class (class-of (eql-specializer-object class))))
+             (while (%i< index size)
+               (let* ((wrapper (%gf-dispatch-table-ref dt index))
+                      hash-index-0?
+                      (cpl (and wrapper
+                                (not (setq hash-index-0?
+                                           (eql 0 (%wrapper-hash-index wrapper))))
+                                (%inited-class-cpl
+                                 (require-type (%wrapper-class wrapper) 'class)))))
+                 (when (or hash-index-0? (and cpl (cpl-index class cpl)))
+                   (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
+                         (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
+                 (setq index (%i+ index 2)))))))
        (setf (%gf-dispatch-table-ref dt 1) nil)))))   ; clear 0-arg gf cm
 

branches/source-tracking-0801/ccl/level-1/l1-clos.lisp

@@ -1910 +1910 @@
               (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
                 (clear-gf-dispatch-table dt)
+                (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
                 (cond ((null (cdr alist))
                        ;; Method is only applicable to a single class.
@@ -2244 +2245 @@
            %find-classes%))
 
+;; Redefined from bootstrapping verison in l1-clos-boot.lisp
+;; Remove the make-instance optimization if the user is adding
+;; a method on initialize-instance, allocate-instance, or shared-initialize
+(defun maybe-remove-make-instance-optimization (gfn method)
+  (when (or (eq gfn #'allocate-instance)
+            (eq gfn #'initialize-instance)
+            (eq gfn #'shared-initialize))
+    (let* ((specializer (car (method-specializers method)))
+           (cell (and (typep specializer 'class)
+                      (gethash (class-name specializer) %find-classes%))))
+      (when cell
+        (setf (class-cell-instantiate cell) '%make-instance)))))            
+
 ;;; Iterate over all known GFs; try to optimize their dcode in cases
 ;;; involving reader methods.

branches/source-tracking-0801/ccl/lib/nfcomp.lisp

@@ -376 +376 @@
     (error 'file-error :pathname file :error-type "File ~S not found"))
   (namestring path))
-
-;;; mb: HACK HACK HACKITY HACK
-(defun read-internal (stream eof-error-p eof-value recursive-p)
-  (setq stream (input-stream-arg stream))
-  (if recursive-p
-    (%read-form stream 0 nil)
-    (let ((%read-objects% nil) (%keep-whitespace% nil))
-      (%read-form stream (if eof-error-p 0) eof-value))))
 
 ;;; orig-file is back-translated when from fcomp-file