Changeset 9734


Ignore:
Timestamp:
Jun 11, 2008, 5:56:56 PM (11 years ago)
Author:
gz
Message:

Fix to not lose the code note in x862-acode-operator-supports-push

Location:
branches/working-0711/ccl
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r9620 r9734  
    33653365
    33663366(defun x862-acode-operator-supports-push (form)
    3367   (setq form (acode-unwrapped-form-value form))
    3368   (when (acode-p form)
    3369     (if (or (eq form *nx-t*)
    3370             (eq form *nx-nil*)
    3371             (let* ((operator (acode-operator form)))
    3372               (member operator *x862-operator-supports-push*)))
    3373         form)))
     3367  (let ((value (acode-unwrapped-form-value form)))
     3368    (when (acode-p value)
     3369      (if (or (eq value *nx-t*)
     3370              (eq value *nx-nil*)
     3371              (let* ((operator (acode-operator value)))
     3372                (member operator *x862-operator-supports-push*)))
     3373        (acode-unwrapped-form form)))))
    33743374
    33753375(defun x862-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-operator)
  • branches/working-0711/ccl/level-1/l1-init.lisp

    r8897 r9734  
    260260(defvar *save-definitions* nil)
    261261(defvar *save-local-symbols* t)
    262 (defvar *save-source-locations* nil
     262(defvar *save-source-locations* #+gz t #-gz nil
    263263  "Controls whether complete source locations is stored.
    264264
  • branches/working-0711/ccl/level-1/l1-reader.lisp

    r9627 r9734  
    26022602            (lambda (stream ignore)
    26032603              (declare (ignore ignore))
    2604               `(quote ,(read stream t nil t)))))
     2604              (multiple-value-bind (form source-note)
     2605                  (read-internal stream t nil t)
     2606                (values `(quote ,form) (and source-note (list source-note)))))))
    26052607
    26062608(defparameter *alternate-line-terminator*
     
    26652667    (declare (ignore subchar))
    26662668    (if (or (null numarg) *read-suppress*)
    2667         (let* ((lst (read-list stream t))
    2668                (len (length lst))
     2669      (multiple-value-bind (lst notes) (read-list stream t)
     2670        (let* ((len (length lst))
    26692671               (vec (make-array len)))
    26702672          (declare (list lst) (fixnum len) (simple-vector vec))
    2671           (dotimes (i len vec)
    2672             (setf (svref vec i) (pop lst))))
     2673          (dotimes (i len)
     2674            (setf (svref vec i) (pop lst)))
     2675          (values vec notes)))
    26732676        (locally
    26742677            (declare (fixnum numarg))
    26752678          (do* ((vec (make-array numarg))
     2679                (notes ())
    26762680                (lastform)
    26772681                (i 0 (1+ i)))
    2678               ((multiple-value-bind (form form-p)
     2682              ((multiple-value-bind (form form-p source-info)
    26792683                   (%read-list-expression stream nil)
    26802684                 (if form-p
    2681                      (setq lastform form)
     2685                     (progn
     2686                       (setq lastform form)
     2687                       (when source-info (push source-info notes)))
    26822688                     (unless (= i numarg)
    26832689                       (if (= i 0)
     
    26882694                             (setf (svref vec j) lastform)))))
    26892695                 (not form-p))
    2690                  vec)
     2696                 (values vec notes))
    26912697            (declare (fixnum i))
    26922698            (setf (svref vec i) lastform)))))))
     
    27252731 #\#
    27262732 #\C
    2727  #'(lambda (stream char arg &aux form)
     2733 #'(lambda (stream char arg)
    27282734     (require-no-numarg char arg )
    2729      (setq form (read stream t nil t))
    2730      (unless *read-suppress* (apply #'complex form))))
     2735     (multiple-value-bind (form note) (read-internal stream t nil t)
     2736       (values (unless *read-suppress* (apply #'complex form)) (and note (list note))))))
    27312737
    27322738(set-dispatch-macro-character
     
    28122818            (lambda (stream subchar numarg)
    28132819              (require-no-numarg subchar numarg)
    2814               `(function ,(read stream t nil t)))))
     2820              (multiple-value-bind (form note) (read-internal stream t nil t)
     2821                (values `(function ,form) (and note (list note)))))))
    28152822
    28162823(set-dispatch-macro-character
     
    29172924(defun read-conditional (stream subchar int)
    29182925  (declare (ignore int))
    2919   (cond ((eq subchar (read-feature stream)) (read stream t nil t))
     2926  (cond ((eq subchar (read-feature stream))
     2927         (multiple-value-bind (form note) (read-internal stream t nil t)
     2928           (values form (and note (list note)))))
    29202929        (t (let* ((*read-suppress* t))
    29212930             (read stream t nil t)
     
    29742983
    29752984(set-dispatch-macro-character #\# #\P
    2976  (qlfun |#P-reader| (stream char flags &aux path (invalid-string "Invalid flags (~S) for pathname ~S"))
     2985 (qlfun |#P-reader| (stream char flags &aux (invalid-string "Invalid flags (~S) for pathname ~S"))
    29772986   (declare (ignore char))
    29782987   (when (null flags) (setq flags 0))
    29792988   (unless (memq flags '(0 1 2 3 4))
    29802989     (unless *read-suppress* (report-bad-arg flags '(integer 0 4))))
    2981    (setq path (read stream t nil t))
    2982    (unless *read-suppress*
    2983      (unless (stringp path) (report-bad-arg path 'string))
    2984      (setq path (pathname path))
    2985      (when (%ilogbitp 0 flags)
    2986        (when (%pathname-type path) (error invalid-string flags path))
    2987        (setf (%pathname-type path) :unspecific))
    2988      (when (%ilogbitp 1 flags)
    2989        (when (%pathname-name path) (error invalid-string flags path))
    2990        (setf (%pathname-name path) ""))
    2991      path)))
     2990   (multiple-value-bind (path note) (read-internal stream t nil t)
     2991     (unless *read-suppress*
     2992       (unless (stringp path) (report-bad-arg path 'string))
     2993       (setq path (pathname path))
     2994       (when (%ilogbitp 0 flags)
     2995         (when (%pathname-type path) (error invalid-string flags path))
     2996         (setf (%pathname-type path) :unspecific))
     2997       (when (%ilogbitp 1 flags)
     2998         (when (%pathname-name path) (error invalid-string flags path))
     2999         (setf (%pathname-name path) ""))
     3000       (values path (and note (list note)))))))
    29923001
    29933002
     
    29993008  code-coverage
    30003009  ;; The actual form - useful during debugging, perhaps remove later.
    3001   #+debug form
     3010  #+(or debug gz) form
    30023011  ;; For the outermost source form, a string (the text of the form).
    30033012  ;; For an inner source form, the source-note of the outer source form.
    30043013  ;; For a random code form (no file info, generated by macros or other source
    3005   ;; transform), code-note of parent form
     3014  ;; transform), source-note of parent form
    30063015  source
    30073016  ;; PC information generated by compiler.  For source notes not stored in
     
    30533062  (print-unreadable-object (note stream :type t :identity t)
    30543063    (let ((text (and (source-note-p note) (ignore-errors (source-note-text note)))))
    3055       #+debug (when (and (null text) (code-note-form note))
    3056                 (setq text (ignore-errors
    3057                              (let ((*print-circle* t))
    3058                                (format nil "~s" (code-note-form note))))))
     3064      #+(or debug gz) (when (null text) (setq text (code-note-form note)))
    30593065      (when (> (length text) 20)
    30603066        (let ((end (position #\Newline text :start 20)))
     
    31363142
    31373143(defun make-source-note (&key form stream start-pos end-pos subform-notes)
    3138   (let ((recording (assoc stream *recording-source-streams*)))
     3144  (let ((recording (assq stream *recording-source-streams*)))
    31393145    (when (and recording (not *read-suppress*))
    31403146      (destructuring-bind (map file-name stream-offset) (cdr recording)
     
    31643170                                 source
    31653171                                 (code-note-source source))))))
    3166     #+debug
     3172    #+(or debug gz)
    31673173    (when form
    31683174      (setf (code-note-form note)
  • branches/working-0711/ccl/library/cover.lisp

    r9578 r9734  
    3131  (cddr entry))
    3232
    33 (defun coverage-subnotes (note)
     33(defun coverage-subnotes (note) ;; reversed parent chain
    3434  (gethash note *coverage-subnotes*))
    3535
     
    273273         (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
    274274         (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
    275          (*entry-code-notes* (make-hash-table :test #'eq :shared nil)))
     275         (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
     276         (index-file (merge-pathnames output-file "index.html"))
     277         (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
     278                                                              (pathnamep statistics))
     279                                                        (merge-pathnames statistics "statistics.csv")
     280                                                        "statistics.csv")
     281                                                      output-file))))
    276282    (get-coverage)
    277283    (ensure-directories-exist directory)
     
    287293                                     :if-exists :supersede
    288294                                     :if-does-not-exist :create)
    289                (report-file-coverage coverage stream external-format))
     295               (report-file-coverage index-file coverage stream external-format))
    290296             (push (list* src-name html-name coverage) paths))))
    291     (setq paths (sort paths #'string< :key #'car))
    292297    (when (null paths)
    293298      (error "No code coverage data available"))
    294     (let* ((index-file (merge-pathnames output-file "index.html"))
    295            (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
    296                                                                 (pathnamep statistics))
    297                                                             (merge-pathnames statistics "statistics.csv")
    298                                                             "statistics.csv")
    299                                                         output-file))))
    300       (with-open-file (html-stream index-file
    301                                    :direction :output
    302                                    :if-exists :supersede
    303                                    :if-does-not-exist :create)
    304         (if stats-file
    305             (with-open-file (stats-stream stats-file
    306                                           :direction :output
    307                                           :if-exists :supersede
    308                                           :if-does-not-exist :create)
    309               (report-coverage-to-streams paths html-stream stats-stream))
    310             (report-coverage-to-streams paths html-stream nil)))
    311       (values index-file stats-file))))
     299    (setq paths (sort paths #'(lambda (path1 path2)
     300                                (let* ((f1 (car path1))
     301                                       (f2 (car path2)))
     302                                  (or (string< (directory-namestring f1)
     303                                               (directory-namestring f2))
     304                                      (and (equal (pathname-directory f1)
     305                                                  (pathname-directory f2))
     306                                           (string< (file-namestring f1)
     307                                                    (file-namestring f2))))))))
     308    (with-open-file (html-stream index-file
     309                                 :direction :output
     310                                 :if-exists :supersede
     311                                 :if-does-not-exist :create)
     312      (if stats-file
     313        (with-open-file (stats-stream stats-file
     314                                      :direction :output
     315                                      :if-exists :supersede
     316                                      :if-does-not-exist :create)
     317          (report-coverage-to-streams paths html-stream stats-stream))
     318        (report-coverage-to-streams paths html-stream nil)))
     319    (values index-file stats-file)))
    312320
    313321(defun report-coverage-to-streams (paths html-stream stats-stream)
     
    327335                                 (pathname-directory (pathname prev)))))
    328336             (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name))))
    329                (format html-stream "<tr class='subheading'><td colspan='11'>~A</td></tr>~%" dir)
     337               (format html-stream "<tr class='subheading'><td colspan='17'>~A</td></tr>~%" dir)
    330338               (when stats-stream (format stats-stream "~a~%" dir))))
    331339        do (coverage-stats-data html-stream stats-stream coverage even report-name src-name))
     
    371379          do (update-text-styles sub styles))))
    372380 
     381(defun entry-note-unambiguous-source (entry-note)
     382  ;; Return the nearest containing source note provided it can be done unambiguously.
     383  (loop for n = entry-note then parent until (source-note-p n)
     384        as parent = (code-note-parent-note n)
     385        do (unless (and parent
     386                        (labels ((no-other-entry-subnotes (n refs)
     387                                   (let ((subs (coverage-subnotes n))
     388                                         (refs (cons n refs)))
     389                                     (declare (dynamic-extent refs))
     390                                     (loop for sub in subs
     391                                           always (or (memq sub refs)
     392                                                      (eq sub entry-note)
     393                                                      (and (not (entry-code-note-p sub))
     394                                                           (no-other-entry-subnotes sub refs)))))))
     395                          (no-other-entry-subnotes parent ())))
     396             (return nil))
     397        finally (return n)))
     398
    373399(defun colorize-source-note (note styles)
    374400  ;; Change coverage flag to 'full if all subforms are covered.
     
    385411  ;; So when showing the colorization of an inner function, we usurp the whole nearest source
    386412  ;; form, provided it can be done unambiguously.
    387   (loop for n = note then parent until (source-note-p n)
    388         as parent = (code-note-parent-note n)
    389         do (unless (and parent
    390                         (labels ((no-other-entry-subnotes (n refs)
    391                                    (let ((subs (coverage-subnotes n))
    392                                          (refs (cons n refs)))
    393                                      (declare (dynamic-extent refs))
    394                                      (loop for sub in subs
    395                                            always (or (memq sub refs)
    396                                                       (eq sub note)
    397                                                       (and (not (entry-code-note-p sub))
    398                                                            (no-other-entry-subnotes sub refs)))))))
    399                           (no-other-entry-subnotes parent ())))
    400              (return nil))
    401         finally (fill-with-text-style (code-note-code-coverage note) n styles))
     413  (let ((n (entry-note-unambiguous-source note)))
     414    (when n
     415      (fill-with-text-style (code-note-code-coverage note) n styles)))
    402416  (update-text-styles note styles))
    403417
     
    434448              do (colorize-function imm styles refs))))
    435449
    436 (defun report-file-coverage (coverage html-stream external-format)
     450(defun report-file-coverage (index-file coverage html-stream external-format)
    437451  "Print a code coverage report of FILE into the stream HTML-STREAM."
    438452  (format html-stream "<html><head>")
     
    447461                             :element-type '(unsigned-byte 2))))
    448462    (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage))
    449     (print-coverage-report html-stream coverage styles source)
     463    (print-file-coverage-report index-file html-stream coverage styles source)
    450464    (format html-stream "</body></html>")))
    451465
    452 (defun print-coverage-report (html-stream coverage styles source)
     466(defun print-file-coverage-report (index-file html-stream coverage styles source)
    453467  (let ((*print-case* :downcase))
    454     (format html-stream "<h3>Coverage report: ~a <br />~%</h3>~%" (file-coverage-file coverage))
    455 
     468    (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%"
     469            (file-namestring index-file)
     470            (file-coverage-file coverage))
    456471    (format html-stream "<table class='summary'>")
    457472    (coverage-stats-head html-stream nil)
     
    500515
    501516(defun coverage-stats-head (html-stream stats-stream)
    502   (format html-stream "<tr class='head-row'><td></td><td class='main-head' colspan='3'>Expressions</td><td class='main-head' colspan='7'>Functions</td></tr>")
     517  (format html-stream "<tr class='head-row'><td></td>")
     518  (format html-stream "<td class='main-head' colspan='5'>Expressions</td>")
     519  (format html-stream "<td class='main-head' colspan='1'>Branches</td>")
     520  (format html-stream "<td class='main-head' colspan='3'>Code Forms</td>")
     521  (format html-stream "<td class='main-head' colspan='7'>Functions</td></tr>")
    503522  (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>"
    504           '("Source file"
    505             "Total" "Covered" "% covered"
    506             "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered"))
     523            '("Source file"
     524              ;; Expressions
     525              "Total" "Entered" "% entered" "Fully covered" "% fully covered"
     526              ;; Branches
     527              "Unreached"
     528              ;; Code forms
     529              "Total" "Covered" "% covered"
     530              ;; Functions
     531              "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered"))
    507532  (when stats-stream
    508533    (format stats-stream "~{~a~^,~}"
    509             '("Source file" "Expressions Total" "Expressions Covered" "% Expressions Covered"
    510               "Functions Total" "Functions Fully Covered" "% Functions Fully Covered"
     534            `("Source file"
     535              "Expressions Total" "Expressions Entered" "% Expressions Entered"
     536              "Unreached Branches"
     537              "Code Forms Total" "Code Forms Covered" "% Code Forms Covered"
     538              "Functions Total" "Functions Fully Covered" "% Functions Fully Covered"
    511539              "Functions Partly Covered" "% Functions Partly Covered"
    512540              "Functions Not Entered" "% Functions Not Entered"))))
     
    519547  (when stats-stream
    520548    (format stats-stream "~a," (file-coverage-file coverage)))
    521   (let ((exp-counts (count-covered-expressions coverage)))
     549
     550  (let ((exp-counts (count-covered-sexps coverage)))
     551    (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts)
     552    (when stats-stream
     553      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
     554
     555  (let ((count (count-unreached-branches coverage)))
     556    (format html-stream "<td>~:[-~;~:*~a~]</td>" count)
     557    (when stats-stream
     558      (format stats-stream "~:[~;~:*~a~]," count)))
     559
     560  (let ((exp-counts (count-covered-aexps coverage)))
    522561    (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts)
    523562    (when stats-stream
    524563      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
    525   (destructuring-bind (total . counts) (count-covered-functions coverage)
     564
     565  (destructuring-bind (total . counts) (count-covered-entry-notes coverage)
    526566    (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>" total counts)
    527567    (when stats-stream
    528568      (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts))))
    529569
    530 (defun count-covered-functions (coverage)
    531   (let ((fully 0) (partly 0) (never 0) (total 0))
    532     (map nil #'(lambda (function)
     570(defun map-coverage-entry-notes (coverage fn)
     571  (map nil #'(lambda (function)
    533572                 (let ((note (function-entry-code-note function)))
    534573                   (when (and note
     
    537576                                  (code-note-parent-note note)
    538577                                  (code-note-source note)))
    539                      (incf total)
    540                      (case (code-note-code-coverage note)
    541                        ((full) (incf fully))
    542                        ((nil) (incf never))
    543                        (t (incf partly))))))
    544          (file-coverage-functions coverage))
     578                     (funcall fn note))))
     579       (file-coverage-functions coverage)))
     580
     581
     582(defun count-covered-entry-notes (coverage)
     583  (let ((fully 0) (partly 0) (never 0) (total 0))
     584    (map-coverage-entry-notes
     585     coverage
     586     #'(lambda (note)
     587         (incf total)
     588         (case (code-note-code-coverage note)
     589           ((full) (incf fully))
     590           ((nil) (incf never))
     591           (t (incf partly)))))
    545592    (if (> total 0)
    546593        (list total
     
    550597        '(0 0 -- 0 -- 0 --))))
    551598
    552 (defun count-covered-expressions (coverage)
     599(defun count-covered-aexps (coverage)
    553600  (let ((covered 0) (total 0))
    554     (map nil #'(lambda (function)
    555                  (let ((note (function-entry-code-note function)))
    556                    (when (and note
    557                               ;; Ignore toplevel functions created by the compiler.
    558                               (or (source-note-p note)
    559                                   (code-note-parent-note note)
    560                                   (code-note-source note)))
    561                      (labels ((rec (note)
    562                                 (incf total)
    563                                 (when (code-note-code-coverage note)
    564                                   (incf covered))
    565                                 (loop for sub in (coverage-subnotes note)
    566                                       unless (entry-code-note-p sub) do (rec sub))))
    567                        (rec note)))))
    568          (file-coverage-functions coverage))
     601    (map-coverage-entry-notes
     602     coverage
     603     (lambda (note)
     604       (labels ((rec (note)
     605                  (incf total)
     606                  (when (code-note-code-coverage note)
     607                    (incf covered))
     608                  (loop for sub in (coverage-subnotes note)
     609                        unless (entry-code-note-p sub) do (rec sub))))
     610         (rec note))))
    569611    (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
    570612
     613(defun count-covered-sexps (coverage)
     614  ;; Count the number of source expressions that have been entered (regardless
     615  ;; of whether or not they are completely covered).
     616  (let ((entered 0) (covered 0) (total 0))
     617    (map-coverage-entry-notes
     618     coverage
     619     (lambda (note)
     620       (labels ((rec (note)
     621                  (when (source-note-p note)
     622                    #+debug (format t "~&~s" note)
     623                    (incf total)
     624                    (when (code-note-code-coverage note)
     625                      (incf entered)
     626                      (when (eq (code-note-code-coverage note) 'full)
     627                        (incf covered))))
     628                  (loop for sub in (coverage-subnotes note)
     629                        unless (entry-code-note-p sub) do (rec sub))))
     630         (rec note))))
     631    (list total
     632          entered (if (> total 0) (* 100.0d0 (/ entered total)) '--)
     633          covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
     634
     635(defun count-unreached-branches (coverage)
     636  ;; Count the number of maximal unentered forms
     637  (let ((count 0))
     638    (map-coverage-entry-notes
     639     coverage
     640     (lambda (note)
     641       (labels ((rec (note parent)
     642                  (case (code-note-code-coverage note)
     643                    ((full) nil)
     644                    ((nil) (when parent (incf count)))
     645                    (t (loop for sub in (coverage-subnotes note)
     646                             unless (entry-code-note-p sub) do (rec sub note))))))
     647         (rec note nil))))
     648    count))
    571649
    572650(defun write-coverage-styles (html-stream)
Note: See TracChangeset for help on using the changeset viewer.