Changeset 14164 for branches/qres/ccl


Ignore:
Timestamp:
Aug 10, 2010, 8:16:19 PM (9 years ago)
Author:
gz
Message:

arrange so don't output coverage acode for compiler-generated toplevel forms

Location:
branches/qres/ccl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl/compiler/nx-basic.lisp

    r14085 r14164  
    739739(defun nx-record-code-coverage-acode (afunc)
    740740  (assert *nx-current-code-note*)
    741   (let* ((form->note (make-hash-table :test #'eq))
    742          (*nx-acode-inner-refs* nil)
    743          (*nx-acode-refs-counter* 0)
    744          (form (decomp-acode (afunc-acode afunc)
    745                              :prettify t
    746                              :hook (lambda (acode form &aux (note (acode-note acode)))
    747                                      ;; For expressions within without-compiling-code-coverage, there is a source
    748                                      ;; note and not a code note, so need to check for code note explicitly.
    749                                      (when (code-note-p note)
    750                                        (dbg-assert (null (gethash form form->note)))
    751                                        (dbg-assert (null (code-note-acode-range note)))
    752                                        (setf (gethash form form->note) note)))))
    753          (package *package*)
    754          (string (with-standard-io-syntax
     741  (let ((form->note (make-hash-table :test #'eq)))
     742    (labels ((hook (acode form &aux (note (acode-note acode)))
     743               ;; For expressions within without-compiling-code-coverage, there is a source
     744               ;; note and not a code note, so need to check for code note explicitly.
     745               (when (code-note-p note)
     746                 (dbg-assert (null (gethash form form->note)))
     747                 (dbg-assert (null (code-note-acode-range note)))
     748                 (setf (gethash form form->note) note)))
     749             (stringify (acode)
     750               (let* ((*nx-acode-inner-refs* nil)
     751                      (*nx-acode-refs-counter* 0)
     752                      (form (decomp-acode acode :prettify t :hook #'hook))
     753                      (package *package*))
     754                 (with-standard-io-syntax
    755755                     (with-output-to-string (*nx-pprint-stream*)
    756756                       (let* ((*package* package)
     
    769769                                             (encode-file-range pos pos)))
    770770                                      (t
    771                                        (dbg-assert (not (null range)))
     771                                       (dbg-assert (not (null range)))
    772772                                       (multiple-value-bind (start end)
    773                                                             (decode-file-range range)
     773                                           (decode-file-range range)
    774774                                         (declare (ignorable end))
    775775                                         (dbg-assert (eq start end))
    776776                                         (setf (code-note-acode-range note)
    777777                                               (encode-file-range start pos))))))))))))))
    778     (iterate store ((afunc afunc))
    779       (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string)
    780       (loop for inner in (afunc-inner-functions afunc)
    781         unless (getf (afunc-lfun-info inner) '%function-acode-string)
    782         do (store inner)))
    783     afunc))
     778             (record (afunc &aux (string (stringify (afunc-acode afunc))))
     779               (iterate store ((afunc afunc))
     780                 (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string)
     781                 (loop for inner in (afunc-inner-functions afunc)
     782                       unless (getf (afunc-lfun-info inner) '%function-acode-string)
     783                         do (store inner)))))
     784      (if (getf (afunc-lfun-info afunc) '%function-source-note)
     785        (record afunc)
     786        ;; If don't have a function source note while recording code coverage, it's
     787        ;; probably a toplevel function consed up by the file compiler.  Don't store it,
     788        ;; as it just confuses things
     789        (loop for inner in (afunc-inner-functions afunc) do (record inner)))))
     790  afunc)
    784791
    785792(defmethod print-object ((ref acode-afunc-ref) stream)
  • branches/qres/ccl/lib/nfcomp.lisp

    r14049 r14164  
    309309      (funcall (compile-named-function
    310310                lambda
     311                :compile-code-coverage nil
    311312                :source-notes *fcomp-source-note-map*
    312313                :env *fasl-compile-time-env*
     
    319320;;; Well, no usable methods by default.  How this is better than
    320321;;; getting a NO-APPLICABLE-METHOD error frankly escapes me,
     322;;; [Hint: this is called even when there is an applicable method]
    321323(defun no-make-load-form-for (object)
    322324  (error "No ~S method is defined for ~s" 'make-load-form object))
     
    959961  (and notes (gethash form notes)))
    960962
     963(defun (setf fcomp-source-note) (note form &aux (notes *fcomp-source-note-map*))
     964  (and notes (setf (gethash form notes) note)))
     965
    961966(defun fcomp-note-source-transformation (original new)
    962967  (let* ((*nx-source-note-map* *fcomp-source-note-map*))
     
    10371042           (*fcomp-stream-position* *fcomp-previous-position*)
    10381043           (*loading-toplevel-location* *fcomp-loading-toplevel-location*)
    1039            (lambda (if T ;; (null (cdr forms))
    1040                      `(lambda () ,@forms)
    1041                      `(lambda ()
    1042                         (macrolet ((load-time-value (value)
    1043                                      (declare (ignore value))
    1044                                      (compiler-function-overflow)))
    1045                           ,@forms)))))
     1044           (body (if T ;; (null (cdr forms))
     1045                   `(progn ,@forms)
     1046                   `(macrolet ((load-time-value (value)
     1047                                 (declare (ignore value))
     1048                                 (compiler-function-overflow)))
     1049                      ,@forms)))
     1050           (lambda `(lambda () ,body)))
     1051      ;; Don't assign a location to the lambda so it doesn't confuse acode printing, but
     1052      ;; arrange to assign it to any inner lambdas.
     1053      (setf (fcomp-source-note body) *loading-toplevel-location*)
    10461054      (setq *fcomp-toplevel-forms* nil)
    10471055      ;(format t "~& Random toplevel form: ~s" lambda)
     
    10491057                     $fasl-lfuncall
    10501058                     env
    1051                      (fcomp-named-function lambda nil env *loading-toplevel-location*))
     1059                     (fcomp-named-function lambda nil env #|*loading-toplevel-location*|#))
    10521060        (compiler-function-overflow ()
    10531061          (if (null (cdr forms))
Note: See TracChangeset for help on using the changeset viewer.