Changeset 8439

Timestamp:

Feb 7, 2008, 12:44:29 PM (17 years ago)

Author:

marco baringer

Message:

More optimizations to source-location.

1) Only use substream to read in the toplevel definition's text, otherwise use displaced arrays.

2) When possible compact ps-source-mapping objcets directly into 64 bit integers

Location:

branches/working-0711/ccl

Files:

• compiler/X86/x86-disassemble.lisp (modified) (2 diffs)
• compiler/X86/x862.lisp (modified) (2 diffs)
• compiler/nx0.lisp (modified) (7 diffs)
• level-1/l1-reader.lisp (modified) (1 diff)
• lib/nfcomp.lisp (modified) (2 diffs)

branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

@@ -2706 +2706 @@
       usual)))
 
-
 (defun string-sans-most-whitespace (string &optional (max-length (length string)))
   (with-output-to-string (sans-whitespace)
@@ -2729 +2728 @@
       (let* ((source-note (getf (%lfun-info function) 'function-source-note))
              (source-info (find-source-at-pc function pc))
-             (text (if source-info
+             (text (if (and source-info
+                            (plusp (car (getf source-info :source-text-range)))
+                            (plusp (cdr (getf source-info :source-text-range))))
                        (string-sans-most-whitespace
                         (subseq (%fast-uncompact (getf source-note :%text))

branches/working-0711/ccl/compiler/X86/x862.lisp

@@ -611 +611 @@
                                       (when (and *compiler-record-source* *definition-source-note*)
                                         (list 'function-source-note
-                                              (source-note-to-list *definition-source-note* :form nil :children nil)))
+                                              (source-note-for-%lfun-info *definition-source-note* :form nil :children nil)))
                                       (when *x862-recorded-symbols*
                                         (list 'function-symbol-map (x862-digest-symbols)))
@@ -685 +685 @@
 
 (defun generate-pc-source-mapping (pc-start pc-end text-start text-end)
-  (if (every #'small-positive-integer-p
-             (list pc-start pc-end text-start text-end))
-    (let ((mapping 0))
-      (setf (ldb (byte 15 0) mapping)  pc-start
-            (ldb (byte 15 15) mapping) pc-end
-            (ldb (byte 15 30) mapping) text-start
-            (ldb (byte 15 45) mapping) text-end)
-      mapping)
-    (vector pc-start pc-end text-start text-end)))
-
-(defstruct (pc-source-mapping (:type vector))
-  pc-start
-  pc-end
-  text-start
-  text-end)
+  (cond
+    ((every #'small-positive-integer-p (list pc-start pc-end text-start text-end))
+      (let ((mapping 0))
+        (setf (ldb (byte 15 0) mapping)  pc-start
+              (ldb (byte 15 15) mapping) pc-end
+              (ldb (byte 15 30) mapping) text-start
+              (ldb (byte 15 45) mapping) text-end)
+        mapping))
+    ((every #'plusp (list pc-start pc-end text-start text-end))
+     (vector pc-start pc-end text-start text-end))
+    (t nil)))
 
 (defun x862-generate-pc-source-map (definition-source-note emitted-source-notes)
   (when *compiler-record-source*
     (let ((def-start (source-note-start definition-source-note))
-          (vec (make-array (length emitted-source-notes))))
-      (flet ((pc-start (note) (aref note ))))
-      (map-into vec
-                (lambda (start)
-                  (make-pc-source-mapping :pc-start (x862-vinsn-note-label-address
-                                                     start
-                                                     t)
-                                          :pc-end (x862-vinsn-note-label-address
+          (vec (make-array (length emitted-source-notes) :fill-pointer 0)))
+      (loop
+        for start in emitted-source-notes
+        for mapping = (generate-pc-source-mapping (x862-vinsn-note-label-address
+                                                       start
+                                                       t)
+                                                  (x862-vinsn-note-label-address
                                                    (vinsn-note-peer start)
-                                                   nil)
-                                          :text-start (- (source-note-start (aref (vinsn-note-info start) 0))
-                                                         def-start)
-                                          :text-end (- (source-note-end (aref (vinsn-note-info start) 0))
-                                                       def-start)))
-                emitted-source-notes)
-      vec)))
+                                                       nil)
+                                                  (- (source-note-start (aref (vinsn-note-info start) 0))
+                                                            def-start)
+                                                  (- (source-note-end (aref (vinsn-note-info start) 0))
+                                                            def-start))
+        when mapping
+          do (vector-push-extend mapping vec))
+      (let ((simple-vec (make-array (length vec))))
+        (map-into simple-vec #'identity vec)
+        simple-vec))))
 
 (defun x862-vinsn-note-label-address (note &optional start-p sym)

branches/working-0711/ccl/compiler/nx0.lisp

@@ -1569 +1569 @@
 (defvar *compile-file-original-buffer-offset* nil)
 
-(defun substream (stream start &optional end)
+(defun substream (stream start end)
   "like subseq, but on streams that support file-position. Leaves stream positioned where it was
 before calling substream."
@@ -1579 +1579 @@
     ((not (open-stream-p stream))
      (if (typep stream 'file-stream)
-          (if (probe-file (stream-pathname stream))
-              (with-open-file (f (stream-pathname stream)) ; I should really understand how this happens.
-                (substream f start end))
-              "")
-          ""))
+       (if (probe-file (stream-pathname stream))
+         (with-open-file (f (stream-pathname stream)) ; I should really understand how this happens.
+           (substream f start end))
+         "")
+       ""))
     (t
      (let ((now (file-position stream)))
@@ -1630 +1630 @@
                        :start (+ start (or *compile-file-original-buffer-offset* 0))
                        :end (+ end (or *compile-file-original-buffer-offset* 0))
-                       :%text (%fast-compact (or text (substream stream start end)))
+                       :%text text
                        :form form
                        :children children)))
@@ -1643 +1643 @@
 ;;; the struct.
 
-(defun source-note-to-list (note &key (start t) (end t) (text t) (form t) (children t) (file-name t))
+(defun source-note-for-%lfun-info (note &key (start t) (end t) (text t) (form t) (children t) (file-name t))
   (append (when start (list :start (source-note-start note)))
-          (when end   (list :end   (source-note-end   note)))
-          (when text  (list :%text  (source-note-%text  note)))
-          (when form  (list :form  (source-note-form  note)))
+          (when end   (list :end  (source-note-end   note)))
+          (when text  (list :%text (%fast-compact (source-note-%text  note))))
+          (when form  (list :form (source-note-form  note)))
           (when children (list :children (source-note-children note)))
           (when file-name (list :file-name (source-note-file-name note)))))
@@ -1675 +1675 @@
     map))
 
+(defun compute-children-text (source-note stream)
+  (unless (source-note-%text source-note)
+    (setf (source-note-%text source-note)
+          (substream stream (source-note-start source-note) (source-note-end source-note))))
+  (dolist (nested (source-note-children source-note))
+    (when nested
+      (unless (source-note-%text nested)
+        (setf (source-note-%text nested)
+              (make-array (- (source-note-end nested) (source-note-start nested))
+                          :displaced-to (source-note-%text source-note)
+                          :displaced-index-offset (- (source-note-start nested)
+                                                     (source-note-start source-note)))))
+      (compute-children-text nested nil)))
+  source-note)
+
 (defun nx1-source-note (nx1-code)
   "Return the source-note for the form which generated NX1-CODE."
@@ -1694 +1709 @@
         (loop
           for pc-map across pc-source-map
-          for pc-start = (aref pc-map 0)
-          for pc-end = (aref pc-map 1)
+          for pc-start = (pc-source-map-pc-start pc-map)
+          for pc-end = (pc-source-map-pc-end pc-map)
           do (when (and (<= pc-start pc pc-end)
                         (or (null best-guess)
@@ -1702 +1717 @@
                      best-length (- pc-end pc-start))))
         (when best-guess
-          (list :pc-range (cons (aref best-guess 0)
-                                (aref best-guess 1))
-                :source-text-range (cons (aref best-guess 2)
-                                         (aref best-guess 3))
+          (list :pc-range (cons (pc-source-map-pc-start best-guess)
+                                (pc-source-map-pc-end best-guess))
+                :source-text-range (cons (pc-source-map-text-start best-guess)
+                                         (pc-source-map-text-end best-guess))
                 :file-name (getf function-source-note :file-name)
                 :text (getf function-source-note :text)))))))

branches/working-0711/ccl/level-1/l1-reader.lisp

@@ -2503 +2503 @@
               (values form
                       t
-                      (when (and (consp form) (record-source-location-on-stream-p stream))
+                      (when (and (not (eql t nested-source-notes))
+                                 (consp form)
+                                 (record-source-location-on-stream-p stream))
+                        ;; mb 2008-02-07: sometime the nested-source-notes end with t, don't know
+                        ;; why. don't really care here.
+                        
+                        (let ((last (last nested-source-notes)))
+                          (when (atom (cdr last))
+                            ;; dotted list.
+                            (setf (cdr last) (list (cdr last)))))
                         (make-source-note :stream stream
                                           :start (1- start)
                                           :end end
                                           :form (car vals)
-                                          :children (labels ((rec (note)
-                                                               ;; use this recursive function to
-                                                               ;; remove nils since
-                                                               ;; nested-source-notes can be a
-                                                               ;; dotted list or an atom
-                                                               (cond
-                                                                 ((consp note)
-                                                                  (if (null (car note))
-                                                                      (rec (cdr note))
-                                                                      (cons (car note) (rec (cdr note)))))
-                                                                 ((source-note-p note)
-                                                                  note)
-                                                                 #| ((null note) '()) 
-                                                                 (t (error "Don't know how to deal with a source note like ~S."
-                                                                           nested-source-notes)) |# )))
-                                                      (rec nested-source-notes)))))))))))
+                                          :children nested-source-notes)))))))))
 
 #|
 (defun %parse-expression-test (string)
-  (let* ((stream (make-string-input-stream string)))
-    (%parse-expression stream (read-char stream t) nil)))
+(let* ((stream (make-string-input-stream string)))
+(%parse-expression stream (read-char stream t) nil)))
 
 (%parse-expression-test ";hello")

branches/working-0711/ccl/lib/nfcomp.lisp

@@ -425 +425 @@
                       (return))
                     (setf form -form
-                          *definition-source-note* source-note
-                          *form-source-note-map* (make-source-note-form-map source-note
+                          *definition-source-note* (compute-children-text source-note *fcomp-stream*)
+                          *form-source-note-map* (make-source-note-form-map *definition-source-note*
                                                                             *form-source-note-map*))))))
             (fcomp-form form env processing-mode)
@@ -497 +497 @@
       (record-form-source-equivalent/list form body)
       (fcomp-macrolet body env processing-mode))
-    ;; special case for passing around source-location info
-    (%source-note (fcomp-form (list 'quote (source-note-to-list *definition-source-note*))
-                              env processing-mode))
     ((%include include) (fcomp-include form env processing-mode))
     (t