Changeset 8394


Ignore:
Timestamp:
Feb 2, 2008, 3:13:49 PM (12 years ago)
Author:
wws
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:
6 edited

Legend:

Unmodified
Added
Removed
  • branches/source-tracking-0801/ccl/compiler/lambda-list.lisp

    r8393 r8394  
    2020
    2121;;; Compiler functions needed elsewhere
    22 
    23 ;;; mb: HACK HACK HACKITY HACK
    24 (defconstant $lfbits-info-bit 23)
    2522
    2623(defun %lfun-info-index (fn)
  • branches/source-tracking-0801/ccl/compiler/nx.lisp

    r8390 r8394  
    203203(provide 'nx)
    204204
    205 ;;; mb: HACK HACK HACKITY HACK
    206 
    207 (defun %compile-time-eval (form env)
    208   (let* ((*target-backend* *host-backend*))
    209     ;; The HANDLER-BIND here is supposed to note WARNINGs that're
    210     ;; signaled during (eval-when (:compile-toplevel) processing; this
    211     ;; in turn is supposed to satisfy a pedantic interpretation of the
    212     ;; spec's requirement that COMPILE-FILE's second and third return
    213     ;; values reflect (all) conditions "detected by the compiler."
    214     ;; (It's kind of sad that CL language design is influenced so
    215     ;; strongly by the views of pedants these days.)
    216     (handler-bind ((warning (lambda (c)
    217                               (setq *fasl-warnings-signalled-p* t)
    218                               (unless (typep c 'style-warning)
    219                                 (setq *fasl-non-style-warnings-signalled-p* t))
    220                               (signal c))))
    221       (funcall (compile-named-function
    222                 `(lambda () ,form)
    223                 :env env
    224                 :policy *compile-time-evaluation-policy*)))))
    225 
    226205(defun define-compile-time-macro (name lambda-expression env)
    227206  (let ((definition-env (definition-environment env)))
  • branches/source-tracking-0801/ccl/compiler/nx0.lisp

    r8390 r8394  
    15941594
    15951595(defun record-source-location (stream)
    1596   (if (and *compiler-record-source* *fcomp-stream*)
    1597       (if (eq *fcomp-stream* stream)
    1598           t
    1599           (progn
    1600             ;; if we don't set *compiler-record-source* to NIL here all subsequent calls to read in
    1601             ;; the debugger will fail. that would be bad.
    1602             (setf *compiler-record-source* nil)
    1603             (error "Attempting to record source on stream ~S but *fcomp-stream* is ~S."
    1604                    stream *fcomp-stream*)))
    1605       nil))
     1596  (and *compiler-record-source*
     1597       *fcomp-stream*
     1598       (eq *fcomp-stream* stream)))
    16061599
    16071600(defstruct (source-note (:constructor %make-source-note))
  • branches/source-tracking-0801/ccl/level-1/l1-clos-boot.lisp

    r7945 r8394  
    835835  (%add-standard-method-to-standard-gf gf method))
    836836
     837;; Redefined in l1-clos.lisp
     838(defun maybe-remove-make-instance-optimization (gfn method)
     839  (declare (ignore gfn method))
     840  nil)
     841
    837842(defun %add-standard-method-to-standard-gf (gfn method)
    838843  (when (%method-gf method)
     
    844849         (qualifiers (%method-qualifiers method)))
    845850    (remove-obsoleted-combined-methods method dt specializers)
     851    (maybe-remove-make-instance-optimization gfn method)
    846852    (apply #'invalidate-initargs-vector-for-gf gfn specializers)
    847853    (dolist (m methods)
     
    962968   (when dt
    963969     (if specializers
    964        (let* ((argnum (%gf-dispatch-table-argnum dt))
    965               (class (nth argnum specializers))
    966               (size (%gf-dispatch-table-size dt))
    967               (index 0))
    968          (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
    969          (if (typep class 'eql-specializer)
    970            (setq class (class-of (eql-specializer-object class))))
    971          (while (%i< index size)
    972            (let* ((wrapper (%gf-dispatch-table-ref dt index))
    973                   hash-index-0?
    974                   (cpl (and wrapper
    975                             (not (setq hash-index-0?
    976                                        (eql 0 (%wrapper-hash-index wrapper))))
    977                             (%inited-class-cpl
    978                              (require-type (%wrapper-class wrapper) 'class)))))
    979              (when (or hash-index-0? (and cpl (cpl-index class cpl)))
    980                (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
    981                      (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
    982              (setq index (%i+ index 2)))))
     970       (let* ((argnum (%gf-dispatch-table-argnum dt)))
     971         (when (>= argnum 0)
     972           (let ((class (nth argnum specializers))
     973                 (size (%gf-dispatch-table-size dt))
     974                 (index 0))
     975             (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
     976             (if (typep class 'eql-specializer)
     977                 (setq class (class-of (eql-specializer-object class))))
     978             (while (%i< index size)
     979               (let* ((wrapper (%gf-dispatch-table-ref dt index))
     980                      hash-index-0?
     981                      (cpl (and wrapper
     982                                (not (setq hash-index-0?
     983                                           (eql 0 (%wrapper-hash-index wrapper))))
     984                                (%inited-class-cpl
     985                                 (require-type (%wrapper-class wrapper) 'class)))))
     986                 (when (or hash-index-0? (and cpl (cpl-index class cpl)))
     987                   (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
     988                         (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
     989                 (setq index (%i+ index 2)))))))
    983990       (setf (%gf-dispatch-table-ref dt 1) nil)))))   ; clear 0-arg gf cm
    984991
  • branches/source-tracking-0801/ccl/level-1/l1-clos.lisp

    r8056 r8394  
    19101910              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
    19111911                (clear-gf-dispatch-table dt)
     1912                (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
    19121913                (cond ((null (cdr alist))
    19131914                       ;; Method is only applicable to a single class.
     
    22442245           %find-classes%))
    22452246
     2247;; Redefined from bootstrapping verison in l1-clos-boot.lisp
     2248;; Remove the make-instance optimization if the user is adding
     2249;; a method on initialize-instance, allocate-instance, or shared-initialize
     2250(defun maybe-remove-make-instance-optimization (gfn method)
     2251  (when (or (eq gfn #'allocate-instance)
     2252            (eq gfn #'initialize-instance)
     2253            (eq gfn #'shared-initialize))
     2254    (let* ((specializer (car (method-specializers method)))
     2255           (cell (and (typep specializer 'class)
     2256                      (gethash (class-name specializer) %find-classes%))))
     2257      (when cell
     2258        (setf (class-cell-instantiate cell) '%make-instance)))))           
     2259
    22462260;;; Iterate over all known GFs; try to optimize their dcode in cases
    22472261;;; involving reader methods.
  • branches/source-tracking-0801/ccl/lib/nfcomp.lisp

    r8390 r8394  
    376376    (error 'file-error :pathname file :error-type "File ~S not found"))
    377377  (namestring path))
    378 
    379 ;;; mb: HACK HACK HACKITY HACK
    380 (defun read-internal (stream eof-error-p eof-value recursive-p)
    381   (setq stream (input-stream-arg stream))
    382   (if recursive-p
    383     (%read-form stream 0 nil)
    384     (let ((%read-objects% nil) (%keep-whitespace% nil))
    385       (%read-form stream (if eof-error-p 0) eof-value))))
    386378
    387379;;; orig-file is back-translated when from fcomp-file
Note: See TracChangeset for help on using the changeset viewer.