Changeset 13591


Ignore:
Timestamp:
Apr 10, 2010, 9:07:57 PM (9 years ago)
Author:
gb
Message:

Try to speed up #n=/#n# a bit:

  • maintain %READ-OBJECTS% as a hash table if its length as an alist exceeds *READ-OBJECTS-HASH-THRESHOLD*.
  • make #n# indicate whether or not the label has been referenced
  • only process circularity in #n= if the label was referenced while the form was being read
  • at most, only process circularity for the current label

While processing circulariy, only descend arrays of element-type T and
structures (and skip the 0th element of structures).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/read.lisp

    r13067 r13591  
    196196
    197197
     198(defun get-read-object (arg)
     199  (if (listp %read-objects%)
     200    (assoc arg %read-objects%)
     201    (gethash arg %read-objects%)))
     202
     203(defparameter *read-objects-hash-threshold* 30)
     204
     205(defun note-read-object (data)
     206  (let* ((lab (car data)))
     207    (if (get-read-object lab)
     208      (%err-disp $xduprdlbl lab)
     209      (if (listp %read-objects%)
     210        (if (< (length %read-objects%) *read-objects-hash-threshold*)
     211          (push data %read-objects%)
     212          (let* ((hash (make-hash-table :test #'eql :shared nil :rehash-size 2.0)))
     213            (dolist (info %read-objects%)
     214              (let* ((lab (car info)))
     215                (setf (gethash lab hash) info)))
     216            (setf (gethash lab hash) data)
     217            (setq %read-objects% hash)))
     218        (setf (gethash lab %read-objects%) data)))))
     219
     220
     221   
     222
    198223(set-dispatch-macro-character #\# #\#
    199224  #'(lambda (stream char arg)
     
    202227        nil
    203228        (if arg
    204           (let ((pair (assoc arg %read-objects%))) ;Not assq, could be bignum!
     229          (let ((pair (get-read-object arg)))
    205230            (if pair
    206               (cdr pair)
     231              (let* ((cell (cdr pair)))
     232                (setf (car cell) t)
     233                (cdr cell))
    207234              (%err-disp $xnordlbl arg)))
    208235          (%err-disp $xrdndarg char)))))
     
    214241     (cond (*read-suppress* (values))
    215242           ((null arg) (%err-disp $xrdndarg char))
    216            ((assoc arg %read-objects%)    ;Not assq, could be bignum!
    217             (%err-disp $xduprdlbl arg))
    218243           (t (setq lab (cons arg nil))
    219               (push (%rplacd lab lab) %read-objects%)
     244              (%rplacd lab (cons nil lab))
     245              (note-read-object lab)
    220246              (setq form (read stream t nil t))
    221               (when (eq form lab)   ;#n= #n#.  No can do.
     247              (when (eq form lab)       ;#n= #n#.  No can do.
    222248                (%err-disp $xnordlbl (%car lab)))
    223               (%rplacd lab form)
    224               (let ((scanned nil))
    225                   (labels ((circle-subst (tree)
    226                              (if (memq tree %read-objects%)
    227                                (progn
    228                                  (unless (memq tree scanned)
    229                                    (setq scanned (%temp-cons tree scanned))
    230                                    (circle-subst (cdr tree)))
    231                                  (cdr tree))
    232                                (let ((gvectorp (and (gvectorp tree)  (not (or (symbolp tree) (functionp tree))))))
    233                                  (unless (or (and (atom tree) (not gvectorp)) (memq tree scanned))
    234                                    (setq scanned (%temp-cons tree scanned))
    235                                    (if gvectorp
    236                                      (let* ((subtype  (typecode tree)))
    237                                        (dotimes (i (uvsize tree))
    238                                          (declare (fixnum i))
    239                                          (unless (and (eql i 0) (eql subtype target::subtag-instance))
    240                                            (setf (uvref tree i) (circle-subst (uvref tree i))))))
    241                                      (locally
    242                                       (declare (type cons tree))
    243                                       (rplaca tree (circle-subst (car tree)))
    244                                       (rplacd tree (circle-subst (cdr tree))))))
    245                                  tree))))
    246                     (declare (dynamic-extent #'circle-subst))
    247                     (circle-subst form)))))))
    248 
    249 
    250 
     249              (%rplacd (cdr lab) form)
     250              (let* ((reffed (cadr lab)))
     251                (if (not reffed)
     252                  form
     253                  (let ((scanned nil))
     254                    (labels ((circle-subst (tree)
     255                               (if (eq tree lab)
     256                                 (progn
     257                                   (unless (memq tree scanned)
     258                                     (setq scanned (%temp-cons tree scanned))
     259                                     (circle-subst (cddr tree)))
     260                                   (cddr tree))
     261                                 (progn
     262                                   (cond ((consp tree)
     263                                          (unless (memq tree scanned)
     264                                            (push tree scanned)
     265                                            (locally
     266                                                (declare (type cons tree))
     267                                              (let* ((orig (car tree))
     268                                                     (new (circle-subst orig)))
     269                                                (unless (eq orig new)
     270                                                  (rplaca tree new))
     271                                                (setq orig (cdr tree)
     272                                                      new (circle-subst orig))
     273                                                (unless (eq orig new)
     274                                                  (rplacd tree new))))))
     275                                         ((let* ((typecode (typecode tree)))
     276                                            (declare (type (unsigned-byte 8) typecode))
     277                                            (or (= typecode target::subtag-simple-vector)
     278                                                (= typecode target::subtag-struct)
     279                                                (= typecode target::subtag-arrayH)))
     280                                          (unless (memq tree scanned)
     281                                            (push tree scanned)
     282                                            (let* ((n (uvsize tree)))
     283                                              (declare (fixnum n))
     284                                              (do* ((i (if (eql (typecode tree) target::subtag-struct) 1 0) (1+ i)))
     285                                                   ((= i n))
     286                                                (declare (fixnum i))
     287                                                (let* ((old (%svref tree i))
     288                                                       (new (circle-subst old)))
     289                                               (unless (eq old new)
     290                                                 (setf (%svref tree i) new))))))))
     291                                   tree))))
     292                      (declare (dynamic-extent #'circle-subst))
     293                      (circle-subst form)))))))))
     294
     295
     296
Note: See TracChangeset for help on using the changeset viewer.