Changeset 14058 for branches


Ignore:
Timestamp:
Jul 27, 2010, 2:21:17 AM (9 years ago)
Author:
gz
Message:

support for code coverage of acode (r13891, r13929, r13942, r13964, r13965, r13966, r14044)

Location:
branches/qres/ccl
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • branches/qres/ccl/compiler/lambda-list.lisp

    r13070 r14058  
    3535(defun function-source-note (fn)
    3636  (getf (%lfun-info fn) '%function-source-note))
     37
     38(defun %function-acode-string (fn)
     39  (getf (%lfun-info fn) '%function-acode-string))
    3740
    3841(defun uncompile-function (fn)
  • branches/qres/ccl/compiler/nx-basic.lisp

    r13565 r14058  
    7777  ;; the note that was being compiled when this note was emitted.
    7878  parent-note
     79  ;; start/end position in the acode string for the toplevel lfun containing this code note.
     80  acode-range
    7981  #+debug-code-notes ;; The actual source form - useful for debugging, otherwise unused.
    8082  form)
     
    484486
    485487 
    486 (defun cons-var (name &optional (bits 0))
    487   (%istruct 'var name bits nil nil nil nil nil nil))
     488(defun nx-cons-var (name &optional (bits 0))
     489  (%istruct 'var name bits nil nil nil nil 0 nil))
    488490
    489491
     
    492494    (report-bad-arg env 'lexical-environment))
    493495  (check-environment-args variable symbol-macro function macro)
    494   (let* ((vars (mapcar #'cons-var variable))
     496  (let* ((vars (mapcar #'nx-cons-var variable))
    495497         (symbol-macros (mapcar #'(lambda (s)
    496498                                    (let* ((sym (car s)))
     
    499501                                                   (not (eq (variable-information sym env) :special)))
    500502                                        (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym))
    501                                       (let ((v (cons-var (car s))))
     503                                      (let ((v (nx-cons-var (car s))))
    502504                                        (setf (var-expansion v) (cons :symbol-macro (cadr s)))
    503505                                        v)))
     
    707709      (cdr (assq name (defenv.structrefs defenv))))))
    708710
     711;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     712;;
     713;;  For code coverage, pretty-print acode to string and store position info in code notes.
     714;;
     715;;  decomp-acode can also be used separately for debugging.
     716;;
     717(defmacro dbg-assert (form)
     718  #+debug-code-notes `(assert ,form))
     719
     720(defvar *acode-right-margin* 120)
     721(defvar *nx-pprint-stream* nil)
     722(defvar *nx-acode-inner-refs* :default)
     723(defvar *nx-acode-refs-counter* 0)
     724
     725(defun nx-pprinting-p (stream)
     726  (and *nx-pprint-stream*
     727       (typep stream 'xp-stream)
     728       (slot-value stream 'xp-structure)
     729       (eq *nx-pprint-stream* (xp-base-stream (slot-value stream 'xp-structure)))))
     730
     731(defstruct acode-ref
     732  object)
     733
     734(defstruct (acode-afunc-ref (:include acode-ref))
     735  afunc
     736  index)
     737
     738(defun nx-record-code-coverage-acode (afunc)
     739  (assert *nx-current-code-note*)
     740  (let* ((form->note (make-hash-table :test #'eq))
     741         (*nx-acode-inner-refs* nil)
     742         (*nx-acode-refs-counter* 0)
     743         (form (decomp-acode (afunc-acode afunc)
     744                             :prettify t
     745                             :hook (lambda (acode form &aux (note (acode-note acode)))
     746                                     ;; For expressions within without-compiling-code-coverage, there is a source
     747                                     ;; note and not a code note, so need to check for code note explicitly.
     748                                     (when (code-note-p note)
     749                                       (dbg-assert (null (gethash form form->note)))
     750                                       (dbg-assert (null (code-note-acode-range note)))
     751                                       (setf (gethash form form->note) note)))))
     752         (package *package*)
     753         (string (with-standard-io-syntax
     754                     (with-output-to-string (*nx-pprint-stream*)
     755                       (let* ((*package* package)
     756                              (*print-right-margin* *acode-right-margin*)
     757                              (*print-case* :downcase)
     758                              (*print-readably* nil))
     759                         (pprint-recording-positions
     760                          form *nx-pprint-stream*
     761                          (lambda (form open-p pos)
     762                            (let* ((note (gethash form form->note))
     763                                   (range (and note (code-note-acode-range note))))
     764                              (when note
     765                                (cond (open-p
     766                                       (dbg-assert (null range))
     767                                       (setf (code-note-acode-range note)
     768                                             (encode-file-range pos pos)))
     769                                      (t
     770                                       (dbg-assert (not (null range)))
     771                                       (multiple-value-bind (start end)
     772                                                            (decode-file-range range)
     773                                         (declare (ignorable end))
     774                                         (dbg-assert (eq start end))
     775                                         (setf (code-note-acode-range note)
     776                                               (encode-file-range start pos))))))))))))))
     777    (iterate store ((afunc afunc))
     778      (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string)
     779      (loop for inner in (afunc-inner-functions afunc)
     780        unless (getf (afunc-lfun-info inner) '%function-acode-string)
     781        do (store inner)))
     782    afunc))
     783
     784(defmethod print-object ((ref acode-afunc-ref) stream)
     785  (if (nx-pprinting-p stream)
     786    (let ((index (acode-afunc-ref-index ref)))
     787      (when index ;; referenced multiple times.
     788        (if (eql index 0)  ;; never referenced before?
     789          (format stream "#~d="
     790                  (setf (acode-afunc-ref-index ref) (incf *nx-acode-refs-counter*)))
     791          ;; If not first reference, just point back.
     792          (return-from print-object (format stream "#~d#" index))))
     793      (write-1 (acode-afunc-ref-object ref) stream))
     794    (call-next-method)))
     795
     796(defmethod print-object ((ref acode-ref) stream)
     797  (if (nx-pprinting-p stream)
     798    (write-1 (acode-ref-object ref) stream)
     799    (call-next-method)))
     800
     801(defun decomp-ref (obj)
     802  (if (and (listp *nx-acode-inner-refs*) ;; code coverage case
     803           (not (acode-p obj)))
     804    (make-acode-ref :object obj)
     805    obj))
     806
     807(defvar *decomp-prettify* nil "If true, loses info but results in more recognizable lisp")
     808
     809(defvar *decomp-hook* nil)
     810
     811(defun decomp-acode (acode &key (hook *decomp-hook*) (prettify *decomp-prettify*))
     812  (let ((*decomp-hook* hook)
     813        (*decomp-prettify* prettify))
     814    (decomp-form acode)))
     815
     816(defun decomp-form (acode)
     817  (cond ((eq acode *nx-t*) t)
     818        ((eq acode *nx-nil*) nil)
     819        (t (let* ((op (car acode))
     820                  (num (length *next-nx-operators*))
     821                  (name (when (and (fixnump op)
     822                                   (<= 0 op)
     823                                   (setq op (logand op operator-id-mask))
     824                                   (< op num))
     825                          (car (nth (- num op 1) *next-nx-operators*))))
     826                  (new (decomp-using-name (or name op) (cdr acode))))
     827             (when *decomp-hook*
     828               (funcall *decomp-hook* acode new))
     829             new))))
     830
     831
     832(defun decomp-afunc (afunc)
     833  (setq afunc (require-type afunc 'afunc))
     834  (dbg-assert (afunc-acode afunc))
     835  (if (listp *nx-acode-inner-refs*)    ;; code coverage case
     836      (let ((ref (find afunc *nx-acode-inner-refs* :key #'acode-afunc-ref-afunc)))
     837        (if ref ;; seen before, mark that multiply referenced.
     838            (setf (acode-afunc-ref-index ref) 0)
     839            (push (setq ref (make-acode-afunc-ref :afunc afunc
     840                                                  :object (decomp-form (afunc-acode afunc))))
     841                  *nx-acode-inner-refs*))
     842        ref)
     843      afunc))
     844
     845(defun decomp-var (var)
     846  (decomp-ref (var-name (require-type var 'var))))
     847
     848(defun decomp-formlist (formlist)
     849  (mapcar #'decomp-form formlist))
     850
     851(defun decomp-arglist (arglist)
     852  (destructuring-bind (stack-forms register-forms) arglist
     853    (nconc (decomp-formlist stack-forms)
     854           (nreverse (decomp-formlist register-forms)))))
     855
     856(defun decomp-lambda-list (req opt rest keys auxen &optional whole)
     857  (flet ((decomp-arg (var)
     858           (if (acode-p var)
     859             (destructuring-bind (op whole req opt rest keys auxen) var
     860               (assert (eq op (%nx1-operator lambda-list))) ;; fake
     861               (decomp-lambda-list req opt rest keys auxen whole))
     862             (decomp-var var))))
     863    (let ((whole (and whole (list '&whole (decomp-arg whole))))
     864          (reqs (mapcar #'decomp-arg req))
     865          (opts (when opt (cons '&optional (apply #'mapcar
     866                                                  (lambda (var init supp)
     867                                                    (if (and (not supp) (eq init *nx-nil*))
     868                                                      (decomp-arg var)
     869                                                      (list* (decomp-arg var)
     870                                                             (decomp-form init)
     871                                                             (and supp (list (decomp-arg supp))))))
     872                                                  opt))))
     873          (rest (when rest (list '&rest (decomp-arg rest))))
     874          (keys (when keys
     875                  (destructuring-bind (aok vars supps inits keyvect) keys
     876                    (nconc
     877                     (when vars
     878                       (cons '&key (map 'list (lambda (var supp init key)
     879                                                (let* ((sym (decomp-arg var))
     880                                                       (arg (if (and (symbolp sym) (eq (make-keyword sym) key))
     881                                                              sym
     882                                                              (list key sym))))
     883                                                  (if (and (not supp) (eq init *nx-nil*) (eq arg sym))
     884                                                    sym
     885                                                    (list* arg
     886                                                           (decomp-form init)
     887                                                           (and supp (list (decomp-arg supp)))))))
     888                                        vars supps inits keyvect)))
     889                     (when aok (list '&allow-other-keys))))))
     890          (auxen (when (car auxen)
     891                   (cons '&aux (apply #'mapcar
     892                                      (lambda (var init)
     893                                        (if (eq init *nx-nil*)
     894                                          (decomp-arg var)
     895                                          (list (decomp-arg var) (decomp-form init))))
     896                                      auxen)))))
     897      (nconc whole reqs opts rest keys auxen))))
     898
     899(defmacro defdecomp (names arglist &body body)
     900  (let ((op-var (car arglist))
     901        (args-vars (cdr arglist))
     902        (op-decls nil)
     903        (args-var (gensym)))
     904    (multiple-value-bind (body decls) (parse-body body nil)
     905    ;; Kludge but good enuff for here
     906      (setq decls (loop for decl in decls
     907                    collect (cons (car decl)
     908                                  (loop for exp in (cdr decl)
     909                                    do (when (and (consp exp) (member op-var (cdr exp)))
     910                                         (push (list (car exp) op-var) op-decls))
     911                                    collect (cons (car exp) (remove op-var (cdr exp)))))))
     912    `(progn
     913       ,@(loop for name in (if (atom names) (list names) names)
     914           collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,args-var)
     915                      (declare ,@op-decls)
     916                      (destructuring-bind ,args-vars ,args-var
     917                        ,@decls
     918                        ,@body)))))))
     919
     920;; Default method
     921(defmethod decomp-using-name (op forms)
     922  `(,op ,@(decomp-formlist forms)))
     923
     924;; not real op, kludge generated below for lambda-bind
     925(defdecomp keyref (op index)
     926  `(,op ,index))
     927
     928(defdecomp immediate (op imm)
     929  (when *decomp-prettify*
     930    (setq op 'quote))
     931  `(,op ,imm))
     932
     933(defdecomp fixnum (op raw-fixnum)
     934  (declare (ignore op))
     935  (decomp-ref raw-fixnum))
     936
     937(defdecomp %function (op symbol)
     938  (when *decomp-prettify*
     939    (setq op 'function))
     940  `(,op ,symbol))
     941
     942(defdecomp simple-function (op afunc)
     943  (when *decomp-prettify*
     944    (setq op 'function))
     945  `(,op ,(decomp-afunc afunc)))
     946
     947(defdecomp closed-function (op afunc)
     948  (when *decomp-prettify*
     949    (setq op 'function))
     950  `(,op ,(decomp-afunc afunc)))
     951
     952(defdecomp (progn prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
     953  `(,op ,@(decomp-formlist form-list)))
     954
     955(defdecomp multiple-value-call (op fn form-list)
     956  `(,op ,(decomp-form fn) ,@(decomp-formlist form-list)))
     957
     958(defdecomp vector (op formlist)
     959  `(,op ,@(decomp-formlist formlist)))
     960
     961(defdecomp (%gvector list* %err-disp) (op arglist)
     962  `(,op ,@(decomp-arglist arglist)))
     963
     964(defdecomp (i386-syscall syscall eabi-syscall poweropen-syscall
     965            i386-ff-call ff-call eabi-ff-call poweropen-ff-call)
     966           (op target argspecs argvals resultspec &rest rest)
     967  `(,op
     968    ,(decomp-form target)
     969    ,@(mapcan (lambda (spec val) (list spec (decomp-form val))) argspecs argvals)
     970    ,resultspec
     971    ,@rest))
     972
     973(defdecomp (consp characterp istruct-typep %ptr-eql int>0-p %izerop endp eq %ilogbitp %base-char-p not neq) (op cc &rest forms)
     974  (if (eq (acode-immediate-operand cc) :eq)
     975    `(,op ,@(decomp-formlist forms))
     976    `(,op ,(decomp-form cc) ,@(decomp-formlist forms))))
     977
     978(defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p)
     979  `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p))))
     980
     981(defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p)
     982  `(,op ,(decomp-form form1) ,(decomp-form form2) ,overflow-p))
     983
     984(defdecomp (immediate-get-xxx %immediate-set-xxx) (op bits &rest forms)
     985  `(,op ,bits ,@(decomp-formlist forms)))
     986
     987(defdecomp call (op fn arglist &optional spread-p)
     988  (setq op (if spread-p 'apply 'funcall))
     989  `(,op ,(decomp-form fn) ,@(decomp-arglist arglist)))
     990
     991(defdecomp lexical-function-call (op afunc arglist &optional spread-p)
     992  (setq op (if *decomp-prettify*
     993             (if spread-p 'apply 'funcall)
     994             (if spread-p 'lexical-apply 'lexical-funcall)))
     995  `(,op ,(decomp-afunc afunc) ,@(decomp-arglist arglist)))
     996
     997(defdecomp self-call (op arglist &optional spread-p)
     998  (declare (Ignore op))
     999  `(,(if spread-p 'self-apply 'self-funcall) ,@(decomp-arglist arglist)))
     1000
     1001(defdecomp (free-reference special-ref bound-special-ref global-ref) (op symbol)
     1002  (if *decomp-prettify*
     1003    (decomp-ref symbol)
     1004    `(,op ,symbol)))
     1005
     1006(defdecomp (setq-special setq-free global-setq) (op symbol form)
     1007  (when *decomp-prettify*
     1008    (setq op 'setq))
     1009  `(,op ,symbol ,(decomp-form form)))
     1010
     1011(defdecomp inherited-arg (op var)
     1012  `(,op ,(decomp-var var)))
     1013
     1014(defdecomp lexical-reference (op var)
     1015  (if *decomp-prettify*
     1016    (decomp-var var)
     1017    `(,op ,(decomp-var var))))
     1018
     1019(defdecomp setq-lexical (op var form)
     1020  (when *decomp-prettify*
     1021    (setq op 'setq))
     1022  `(,op ,(decomp-var var) ,(decomp-form form)))
     1023
     1024(defdecomp (let let* with-downward-closures) (op vars vals body p2decls)
     1025  (declare (ignore p2decls))
     1026  `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-form val))) vars vals)
     1027    ,(decomp-form body)))
     1028
     1029(defdecomp %decls-body (op form p2decls)
     1030  (declare (ignore p2decls))
     1031  `(,op ,(decomp-form form)))
     1032
     1033(defdecomp multiple-value-bind (op vars form body p2decls)
     1034  (declare (ignore p2decls))
     1035  `(,op ,(mapcar #'decomp-var vars) ,(decomp-form form) ,(decomp-form body)))
     1036
     1037
     1038(defdecomp lambda-list (op req opt rest keys auxen body p2decls &optional code-note)
     1039  (declare (ignore p2decls code-note))
     1040  (when *decomp-prettify*
     1041    (setq op 'lambda))
     1042  `(,op ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-form body)))
     1043
     1044(defdecomp debind (op ll form req opt rest keys auxen whole body p2decls cdr-p)
     1045  (declare (ignore ll p2decls cdr-p))
     1046  `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-form form) ,(decomp-form body)))
     1047
     1048(defdecomp lambda-bind (op vals req rest keys-p auxen body p2decls)
     1049  (declare (ignore keys-p p2decls))
     1050  (when (find-if #'fixnump (cadr auxen))
     1051    (destructuring-bind (vars vals) auxen
     1052      (setq auxen (list vars
     1053                        (mapcar (lambda (x) (if (fixnump x) `(keyref ,x) x)) vals)))))
     1054  (let ((lambda-list (decomp-lambda-list req nil rest nil  auxen)))
     1055    `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-form body))))
     1056
     1057(defdecomp (flet labels) (op vars afuncs body p2decls)
     1058  (declare (ignore p2decls))
     1059  `(,op ,(mapcar (lambda (var afunc)
     1060                            (list (decomp-var var) (decomp-afunc afunc)))
     1061                          vars afuncs)
     1062    ,(decomp-form body)))
     1063
     1064(defdecomp local-go (op tag)
     1065  (when *decomp-prettify*
     1066    (setq op 'go))
     1067  `(,op ,(car tag)))
     1068
     1069(defdecomp tag-label (op &rest tag)
     1070  (if *decomp-prettify*
     1071    (decomp-ref (car tag))
     1072    `(,op ,(car tag))))
     1073
     1074(defdecomp local-tagbody (op tags forms)
     1075  (declare (ignore tags))
     1076  (when *decomp-prettify*
     1077    (setq op 'tagbody))
     1078  `(,op ,@(decomp-formlist forms)))
     1079
     1080(defdecomp local-block (op block body)
     1081  (when *decomp-prettify*
     1082    (setq op 'block))
     1083  `(,op ,(car block) ,(decomp-form body)))
     1084
     1085(defdecomp local-return-from (op block form)
     1086  (when *decomp-prettify*
     1087    (setq op 'return-from))
     1088  `(,op ,(car block) ,(decomp-form form)))
     1089
    7091090; end
  • branches/qres/ccl/compiler/nx0.lisp

    r14049 r14058  
    6161
    6262(defvar *nx1-operators* (make-hash-table :size 300 :test #'eq))
    63 
    64 
    65 ; The compiler can (generally) use temporary vectors for VARs.
    66 (defun nx-cons-var (name &optional (bits 0))
    67   (%istruct 'var name bits nil nil nil nil 0 nil))
    68 
    69 
    70 
    7163
    7264(defvar *nx-lambdalist* (make-symbol "lambdalist"))
     
    14451437    (setf (afunc-vcells p) *nx1-vcells*)
    14461438    (setf (afunc-fcells p) *nx1-fcells*)
     1439    (when *nx-current-code-note*
     1440      (when (null q) ;; toplevel functions only
     1441        (nx-record-code-coverage-acode p)))
    14471442    (let* ((warnings (merge-compiler-warnings *nx-warnings*))
    14481443           (name *nx-cur-func-name*))       
  • branches/qres/ccl/level-1/l1-reader.lisp

    r14049 r14058  
    30873087      (cons start-pos end-pos))))
    30883088
     3089(defun decode-file-range (range)
     3090  (when range
     3091    (if (consp range)
     3092      (values (car range) (cdr range))
     3093      (let ((start-pos (ash range -14)))
     3094        (values start-pos (+ start-pos (logand range #x3FFF)))))))
     3095
    30893096(defun source-note-text (source-note &optional start end)
    30903097  (when source-note
  • branches/qres/ccl/lib/pprint.lisp

    r11834 r14058  
    175175  (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
    176176  (structures (make-hash-table :test #'eq) :type (or null hash-table))
    177   (others nil :type list))
     177  (others nil :type list)
     178  (commit-hook nil))
    178179
    179180;The list and the hash-tables contain entries of the
     
    199200      :conses-with-cars new-conses-with-cars
    200201      :structures new-structures
    201       :others (copy-list (others table)))))
     202      :others (copy-list (others table))
     203      :commit-hook (commit-hook table))))
    202204
    203205
     
    939941                          (maybe-too-large xp qleft queue linel)))
    940942               (T T)) ;(:linear :unconditional :mandatory)
    941          (output-line xp qleft)
    942          (setup-for-next-line xp qleft))))
     943         (output-line-and-setup-for-next xp qleft))))
    943944    (setf (xp-qleft xp) (setq qleft (qnext qleft))))
    944945  (when flush-out? (flush xp)))))
     
    947948
    948949(defun flush (xp)
    949   (let ((ostream (xp-out-stream xp)))
     950  (let ((ostream (xp-out-stream xp))
     951        (len (xp-buffer-ptr xp)))
     952    (when (and *print-pprint-dispatch* (commit-hook *print-pprint-dispatch*))
     953      (funcall (commit-hook *print-pprint-dispatch*) xp len 0))
    950954    (when ostream     
    951       (write-string (xp-buffer xp) ostream :start 0 :end (xp-buffer-ptr xp)))
    952     (incf (xp-buffer-offset xp) (xp-buffer-ptr xp))
    953     (incf (xp-charpos xp) (xp-buffer-ptr xp))
     955      (write-string (xp-buffer xp) ostream :start 0 :end len))
     956    (incf (xp-buffer-offset xp) len)
     957    (incf (xp-charpos xp) len)
    954958    (setf (xp-buffer-ptr xp) 0)))
    955959
     
    968972;This prints out a line of stuff.
    969973
    970 (defun output-line (xp Qentry)
    971   (flet ((find-not-char-reverse (buffer out-point)
    972            (declare (type simple-base-string buffer) (type fixnum out-point))
    973            (do ((i (%i- out-point 1) (%i- i 1)))
    974                ((%i< i 0) nil)
    975              (when (or (neq (schar buffer i) #\Space)
    976                        ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be
    977                        ;; quoted; don't bother checking for that, no big harm leaving the space even if
    978                        ;; not totally necessary).
    979                        (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\)))
    980                (return i)))))
    981     (let* ((queue (xp-queue xp))
    982            (out-point (BP<-TP xp (xpq-pos queue Qentry)))
    983            (last-non-blank (find-not-char-reverse (xp-buffer xp) out-point))
    984            (end (cond ((memq (xpq-kind queue Qentry) '(:fresh :unconditional)) out-point)
    985                       (last-non-blank (%i+ 1 last-non-blank))
    986                       (T 0)))
    987            (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp))))))
    988       (when line-limit-exit
    989         (setf (xp-buffer-ptr xp) end)          ;truncate pending output.
    990         (write-string+++ " .." xp 0 3)
    991         (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp))
    992         (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp))
    993         (setf (xp-qleft xp) (qnext (xp-qright xp)))
    994         ;(setq *abbreviation-happened* '*print-lines*)
    995         (throw 'line-limit-abbreviation-exit T))
    996       (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp)))
    997       (let ((bstream (xp-out-stream xp)))
    998         (when bstream
    999           (write-string (xp-buffer xp) bstream :start 0 :end end)
    1000           (stream-write-char bstream #\newline))))))
    1001 
    1002 (defun setup-for-next-line (xp Qentry)
     974(defun output-line-and-setup-for-next (xp Qentry)
    1003975  (let* ((queue (xp-queue xp))
    1004976         (out-point (BP<-TP xp (xpq-pos queue Qentry)))
    1005          (prefix-end
    1006           (cond ((memq (xpq-kind queue Qentry) '(:unconditional :fresh))
    1007                  (non-blank-prefix-ptr xp))
    1008                 (T (prefix-ptr xp))))
    1009          (change (- prefix-end out-point)))
    1010     (declare (fixnum out-point prefix-end change))
     977         (unconditional-p (memq (xpq-kind queue Qentry) '(:fresh :unconditional)))
     978         (end (if unconditional-p
     979                out-point
     980                (let ((buffer (xp-buffer xp)))
     981                  (declare (type simple-base-string buffer))
     982                  (do ((i (%i- out-point 1) (%i- i 1)))
     983                      ((%i< i 0) 0)
     984                    (when (or (neq (schar buffer i) #\Space)
     985                              ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be
     986                              ;; quoted; don't bother checking for that, no big harm leaving the space even if
     987                              ;; not totally necessary).
     988                              (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\)))
     989                      (return (%i+ i 1)))))))
     990         (prefix-end
     991          (if unconditional-p (non-blank-prefix-ptr xp) (prefix-ptr xp)))
     992         (old-ptr (xp-buffer-ptr xp))
     993         (new-ptr (%i+ old-ptr (%i- prefix-end out-point)))
     994         (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp))))))
     995    (when line-limit-exit
     996      (setf (xp-buffer-ptr xp) end)          ;truncate pending output.
     997      (write-string+++ " .." xp 0 3)
     998      (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp))
     999      (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp))
     1000      (setf (xp-qleft xp) (qnext (xp-qright xp)))
     1001      ;(setq *abbreviation-happened* '*print-lines*)
     1002      (throw 'line-limit-abbreviation-exit T))
     1003    (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp)))
     1004    (when (and *print-pprint-dispatch* (commit-hook *print-pprint-dispatch*))
     1005      (funcall (commit-hook *print-pprint-dispatch*) xp out-point prefix-end))
     1006    (let ((bstream (xp-out-stream xp)))
     1007      (when bstream
     1008        (write-string (xp-buffer xp) bstream :start 0 :end end)
     1009        (stream-write-char bstream #\newline)))
    10111010    (setf (xp-charpos xp) 0)
    1012     (when (plusp change)                  ;almost never happens
    1013       (xp-check-size (xp-buffer xp) (%i+ (xp-buffer-ptr xp) change)
    1014                      #.buffer-min-size #.buffer-entry-size))
     1011    (when (%i> new-ptr old-ptr)                  ;almost never happens
     1012      (xp-check-size (xp-buffer xp) new-ptr #.buffer-min-size #.buffer-entry-size))
     1013    (setf (xp-buffer-ptr xp) new-ptr)
     1014    (decf (xp-buffer-offset xp) (- prefix-end out-point))
    10151015    (let ((buffer (xp-buffer xp)))
    1016       (replace buffer buffer :start1 prefix-end
    1017                :start2 out-point :end2 (xp-buffer-ptr xp))
     1016      (replace buffer buffer :start1 prefix-end :start2 out-point :end2 old-ptr)
    10181017      (replace buffer (xp-prefix xp) :end2 prefix-end)
    1019       (setf (xp-buffer-ptr xp) (%i+ (xp-buffer-ptr xp) change))
    1020       (setf (xp-buffer-offset xp) (%i- (xp-buffer-offset xp) change))
    1021       (when (not (memq (xpq-kind queue Qentry) '(:unconditional :fresh)))
     1018      (unless unconditional-p
    10221019        (setf (section-start-line xp) (xp-line-no xp))))))
     1020
     1021
    10231022
    10241023(defun set-indentation-prefix (xp new-position)
     
    13101309(defmethod stream-finish-output ((xp xp-structure))
    13111310  (attempt-to-output xp t t))
     1311
     1312(defun pprint-recording-positions (form stream recorder)
     1313  ;; The hair here comes from the fact that the pretty printer backtracks to insert newlines.
     1314  (let* ((old-table *print-pprint-dispatch*)
     1315         (rec-pending nil)
     1316         (record (require-type recorder 'function)))
     1317    (flet ((rec-pprint (xp object)
     1318             #+gz (assert (or (null rec-pending)
     1319                              (<= (caar rec-pending) (xp-buffer-ptr xp))))
     1320             (let ((real-printer (get-printer object old-table)))
     1321               (when real-printer
     1322                 (push (list* (xp-buffer-ptr xp) t object) rec-pending)
     1323                 (funcall real-printer xp object)
     1324                 (push (list* (xp-buffer-ptr xp) nil object) rec-pending))))
     1325           (rec-commit (xp commited inserted)
     1326             (loop with change = (- inserted commited)
     1327               as last = nil then pending
     1328               as pending = rec-pending then (cdr pending) while pending
     1329               do (when (<= (caar pending) commited) ;; commit the rest.
     1330                    (if last
     1331                      (setf (cdr last) nil)
     1332                      (setf rec-pending nil))
     1333                    (loop with start = (stream-position (xp-out-stream xp))
     1334                      for (offset open-p . object) in (nreverse pending)
     1335                      do (funcall record object open-p (+ start offset)))
     1336                    (return nil))
     1337               do (incf (caar pending) change))))
     1338      (let* ((*print-pretty* t)
     1339             (*print-circle* nil)
     1340             (*print-length* nil)
     1341             (*print-level* nil)
     1342             (*print-lines* nil)
     1343             (*print-miser-width* nil)
     1344             (*read-suppress* nil)
     1345             (*print-pprint-dispatch* (make-pprint-dispatch-table :commit-hook #'rec-commit)))
     1346        (set-pprint-dispatch 'cons #'rec-pprint)
     1347        (write-1 form stream)
     1348        #+gz (assert (null rec-pending))))
     1349    form))
     1350
    13121351
    13131352
  • branches/qres/ccl/library/cover.lisp

    r13685 r14058  
    4747          without-compiling-code-coverage))
    4848
    49 (defconstant $not-executed-style 2)
    50 (defconstant $totally-covered-style 5)
    51 (defconstant $partially-covered-style 6)
     49(defconstant $no-style 0)
     50(defconstant $not-executed-style 1)
     51(defconstant $totally-covered-style 2)
     52(defconstant $partially-covered-style 3)
    5253
    5354(defparameter *file-coverage* ())
     
    5556(defparameter *emitted-code-notes* (make-hash-table :test #'eq))
    5657(defparameter *entry-code-notes* (make-hash-table :test #'eq))
    57 
     58(defparameter *code-note-acode-strings* (make-hash-table :test #'eq))
     59
     60(defparameter *coverage-acode-queue* nil)
    5861
    5962(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
     
    8386(defun entry-code-note-p (note)
    8487  (gethash note *entry-code-notes*))
     88
     89(defun code-note-acode-string (note)
     90  (gethash note *code-note-acode-strings*))
    8591
    8692(defun map-function-coverage (lfun fn &optional refs)
     
    94100              do (map-function-coverage imm fn refs))))
    95101
    96 (defun get-function-coverage (fn refs)
     102(defun get-function-coverage (fn refs acode)
    97103  (let ((entry (function-entry-code-note fn))
    98         (refs (cons fn refs)))
     104        (refs (cons fn refs))
     105        (acode (or (%function-acode-string fn) acode)))
    99106    (declare (dynamic-extent refs))
    100107    (when entry
    101108      (assert (eq fn (gethash entry *entry-code-notes* fn)))
    102       (setf (gethash entry *entry-code-notes*) fn))
     109      (setf (gethash entry *entry-code-notes*) fn)
     110      (when acode
     111        (setf (gethash entry *code-note-acode-strings*) acode)))
    103112    (nconc
    104113     (and entry (list fn))
    105114     (lfunloop for imm in fn
    106115       when (code-note-p imm)
    107        do (setf (gethash imm *emitted-code-notes*) t)
     116       do (progn
     117            (setf (gethash imm *emitted-code-notes*) t)
     118            (when acode
     119              (setf (gethash imm *code-note-acode-strings*) acode)))
    108120       when (and (functionp imm)
    109121                 (not (memq imm refs)))
    110        nconc (get-function-coverage imm refs)))))
     122       nconc (get-function-coverage imm refs acode)))))
    111123
    112124(defun code-covered-info.file (data) (and (consp data) (car data)))
     
    128140  (clrhash *emitted-code-notes*)
    129141  (clrhash *entry-code-notes*)
     142  (clrhash *code-note-acode-strings*)
    130143  (loop for data in *code-covered-functions*
    131144        do (let* ((file (code-covered-info.file data))
     
    138151                            (delete-duplicates
    139152                             (loop for fn across toplevel-functions
    140                                    nconc (get-function-coverage fn nil)))
     153                                   nconc (get-function-coverage fn nil nil)))
    141154                            toplevel-functions)
    142155                     *file-coverage*))))
     
    146159                 while parent
    147160                 do (pushnew n (gethash parent *coverage-subnotes*))
    148                  until (emitted-code-note-p parent))))
     161                 until (emitted-code-note-p parent)))
     162  (let ((hash (make-hash-table :test #'eq)))
     163    ;; distribute entry acode to the toplevel source note it belongs to.
     164    (loop for entry being the hash-key of *entry-code-notes* using (hash-value fn)
     165      as acode = (code-note-acode-string entry)
     166      as sn = (entry-note-unambiguous-source entry)
     167      as toplevel-sn = (function-source-form-note fn)
     168      do (when sn
     169           (assert toplevel-sn)
     170           (let* ((pos (source-note-end-pos sn))
     171                  (cell (assq acode (gethash toplevel-sn hash))))
     172             (if cell
     173               (setf (cdr cell) (max (cdr cell) pos))
     174               (push (cons acode pos) (gethash toplevel-sn hash))))))
     175    (setf *coverage-acode-queue*
     176          (sort (loop for sn being the hash-key of hash using (hash-value alist)
     177                  collect (cons (source-note-end-pos sn)
     178                                (mapcar #'car (sort alist #'< :key #'cdr))))
     179                #'< :key #'car))))
    149180
    150181#+debug
     
    159190             (when (entry-code-note-p note)
    160191               (format t " (Entry to ~s)" (entry-code-note-p note)))
     192             (when (code-note-acode-range note)
     193               (multiple-value-bind (s e) (decode-file-range (code-note-acode-range note))
     194                 (format t " [acode ~a:~a]" s e)))
    161195             (format t "~%")
    162196             (when (code-note-p note)
     
    573607
    574608
     609(defun style-for-coverage (coverage)
     610  (case coverage
     611    ((full) $totally-covered-style)
     612    ((nil) $not-executed-style)
     613    (t $partially-covered-style)))
     614 
    575615(defun fill-with-text-style (coverage location-note styles)
    576   (let ((style (case coverage
    577                  ((full) $totally-covered-style)
    578                  ((nil) $not-executed-style)
    579                  (t $partially-covered-style))))
    580     (fill styles style
    581           :start (source-note-start-pos location-note)
    582           :end (source-note-end-pos location-note))))
     616  (fill styles (style-for-coverage coverage)
     617        :start (source-note-start-pos location-note)
     618        :end (source-note-end-pos location-note)))
    583619
    584620(defun update-text-styles (note styles)
     
    642678             (return sn))))
    643679
    644  
    645 (defun colorize-function (fn styles &optional refs)
     680(defun colorize-acode (fn acode-styles)
     681  (let* ((acode (%function-acode-string fn))
     682         (note (function-entry-code-note fn))
     683         (range (and note (code-note-acode-range note))))
     684    (when (and acode range)
     685      (let ((styles (or (gethash acode acode-styles)
     686                        (setf (gethash acode acode-styles)
     687                              (make-array (length acode)
     688                                          :initial-element $no-style
     689                                          :element-type '(unsigned-byte 2))))))
     690        (iterate update ((note note))
     691          (multiple-value-bind (start end) (decode-file-range (code-note-acode-range note))
     692            (when (and start
     693                       (setq start (position-if-not #'whitespacep acode :start start :end end)))
     694              (fill styles (style-for-coverage (code-note-code-coverage note))
     695                    :start start
     696                    :end end)))
     697          (loop for sub in (coverage-subnotes note)
     698            unless (entry-code-note-p sub)
     699            do (update sub)))))))
     700
     701(defun colorize-function (fn styles acode-styles &optional refs)
    646702  (let* ((note (function-entry-code-note fn))
    647703         (source (function-source-form-note fn))
     
    650706    ;; Colorize the body of the function
    651707    (when note
    652       (colorize-source-note note styles))
     708      (colorize-source-note note styles)
     709      (colorize-acode fn acode-styles))
    653710    ;; And now any subfunction references
    654711    (lfunloop for imm in fn
     
    664721                                      (warn "Ignoring ref to ~s from ~s" imm fn)
    665722                                      nil)))
    666               do (colorize-function imm styles refs))))
     723              do (colorize-function imm styles acode-styles refs))))
    667724
    668725(defun report-file-coverage (index-file coverage html-stream external-format)
     
    676733                     string)))
    677734         (styles (make-array (length source)
    678                              :initial-element 0
    679                              :element-type '(unsigned-byte 2))))
    680     (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage))
    681     (print-file-coverage-report index-file html-stream coverage styles source)
     735                             :initial-element $no-style
     736                             :element-type '(unsigned-byte 2)))
     737         (acode-styles (make-hash-table :test #'eq)))
     738    (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) (file-coverage-toplevel-functions coverage))
     739    (print-file-coverage-report index-file html-stream coverage styles acode-styles source)
    682740    (format html-stream "</body></html>")))
    683741
    684 (defun print-file-coverage-report (index-file html-stream coverage styles source)
     742(defun print-file-coverage-report (index-file html-stream coverage styles acode-styles source)
    685743  (let ((*print-case* :downcase))
    686744    (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%"
     
    694752
    695753    (format html-stream "<div class='key'><b>Key</b><br />~%")
    696     (format html-stream "<div class='state-~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
    697     (format html-stream "<div class='state-~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
    698     (format html-stream "<div class='state-~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
    699     (format html-stream "<p></p><div><code>~%")
    700 
    701     (flet ((line (line)
    702              (unless (eql line 0)
    703                (format html-stream "</span>"))
    704              (incf line)
    705              (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code>&#160;" line)
    706              line))
    707       (loop with line = (line 0) with col = 0
    708         for last-style = nil then style
    709         for char across source
    710         for style across styles
    711         do (unless (eq style last-style)
    712              (when last-style
    713                (format html-stream "</span>"))
    714              (format html-stream "<span class='state-~a'>" style))
     754    (format html-stream "<div class='st~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
     755    (format html-stream "<div class='st~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
     756    (format html-stream "<div class='st~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
     757    (format html-stream "</div><p></p>~%")
     758
     759    ;; Output source intertwined with acode
     760    (iterate output ((start 0) (line 0))
     761      (format html-stream "<div class='source'><code>")
     762      (let ((next (car *coverage-acode-queue*)))
     763        (multiple-value-bind (end last-line)
     764                             (output-styled html-stream source styles
     765                                            :start start
     766                                            :line line
     767                                            :limit (car next))
     768          (format html-stream "</code></div>~%")
     769          (when (and next end (<= (car next) end))
     770            (destructuring-bind (pos . strings) next
     771              (format html-stream "<a href=javascript:swap('~d')><span class='toggle' id='p~:*~d'>Show expansion</span></a>~%~
     772                                   <div class='acode' id='a~:*~d'><code>" pos)
     773              (loop for acode in strings as styles = (gethash acode acode-styles)
     774                do (assert styles)
     775                do (output-styled html-stream acode styles)
     776                do (fresh-line html-stream))
     777              (format html-stream "</code></div><hr/>~%"))
     778            (pop *coverage-acode-queue*)
     779            (output (1+ end) last-line)))))))
     780
     781(defun output-styled (html-stream source styles &key (start 0) line limit)
     782  (let ((last-style $no-style)
     783        (col 0)
     784        (line line))
     785    (labels ((outch (char)
     786               (if (eql char #\Tab)
     787                 (dotimes (i (- 8 (mod col 8)))
     788                   (incf col)
     789                   (write-string " " html-stream))
     790                 (progn
     791                   (incf col)
     792                   (if (or (alphanumericp char) (find char "()+-:* ")) ;; common and safe
     793                     (write-char char html-stream)
     794                     (format html-stream "&#~D;" (char-code char))))))
     795             (start-line ()
     796               (when line
     797                 (incf line)
     798                 (format html-stream "<span class='line'>~A</span>" line))
     799               (write-char #\space html-stream)
     800               (setq col 0))
     801             (set-style (new)
     802               (unless (eq last-style new)
     803                 (unless (eq last-style $no-style) (format html-stream "</span>"))
     804                 (unless (eq new $no-style) (format html-stream "<span class='st~a'>" new))
     805                 (setq last-style new)))
     806             (end-line ()
     807               (set-style $no-style)
     808               (format html-stream "~%")))
     809      (declare (inline outch start-line end-line))
     810      (unless limit (setq limit (length source)))
     811      (start-line)
     812      (loop
     813        for pos from start below (length source)
     814        as char = (aref source pos) as style = (aref styles pos)
     815        do (set-style style)
    715816        do (case char
    716817             ((#\Newline)
    717               (setq style nil)
    718               (setq col 0)
    719               (setq line (line line)))
    720              ((#\Space)
    721               (incf col)
    722               (write-string "&#160;" html-stream))
    723              ((#\Tab)
    724               (dotimes (i (- 8 (mod col 8)))
    725                 (incf col)
    726                 (write-string "&#160;" html-stream)))
     818              (end-line)
     819              (when (<= limit pos)
     820                (return (values pos line)))
     821              (start-line))
    727822             (t
    728               (incf col)
    729               (if (alphanumericp char)
    730                 (write-char char html-stream)
    731                 (format html-stream "&#~D;" (char-code char))))))
    732       (format html-stream "</code></div>"))))
     823              (outch char)))
     824        finally (end-line)))))
    733825
    734826
     
    875967(defun write-coverage-styles (html-stream)
    876968  (format html-stream "<style type='text/css'>
    877 *.state-~a { background-color: #ffaaaa }
    878 *.state-~a { background-color: #aaffaa }
    879 *.state-~a { background-color: #44dd44 }
    880 div.key { margin: 20px; width: 88ex }
    881 div.source { width: 98ex; background-color: #eeeeee; padding-left: 5px;
     969*.st~a { background-color: #ffaaaa }
     970*.st~a { background-color: #aaffaa }
     971*.st~a { background-color: #44dd44 }
     972*.key { margin: 20px; width: 88ex }
     973*.source { width: 120ex; background-color: #eeeeee; padding-left: 5px;
    882974             /* border-style: solid none none none; border-width: 1px;
    883              border-color: #dddddd */ }
    884 
    885 *.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
     975             border-color: #dddddd */
     976             white-space: pre; }
     977
     978*.acode { border-left: 1px dashed #c0c0c0;
     979         margin-top: 1ex;
     980         margin-left: 6ex;
     981         margin-bottom: 2ex;
     982         white-space: pre;
     983         display: none; }
     984
     985*.line { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
     986
     987*.toggle { font-size: small; }
    886988
    887989table.summary tr.head-row { background-color: #aaaaff }
     
    892994table.summary tr.subheading { background-color: #aaaaff}
    893995table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
    894 </style>"
     996
     997</style>
     998
     999<script type='text/javascript'>
     1000function swap (id) {
     1001  var acode = document.getElementById('a' + id);
     1002  var prompt = document.getElementById('p' + id);
     1003  if (acode.style.display == 'block') {
     1004      acode.style.display = 'none';
     1005      prompt.innerHTML = 'Show expansion';
     1006  } else {
     1007    acode.style.display = 'block';
     1008    prompt.innerHTML = 'Hide expansion';
     1009  }
     1010}
     1011</script>
     1012"
    8951013          $not-executed-style
    8961014          $partially-covered-style
    8971015          $totally-covered-style
    8981016          ))
     1017
Note: See TracChangeset for help on using the changeset viewer.