Changeset 13966


Ignore:
Timestamp:
Jul 15, 2010, 5:54:52 PM (9 years ago)
Author:
gz
Message:

Record code coverage acode string and positions

Location:
trunk/source/compiler
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx-basic.lisp

    r13891 r13966  
    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)))
     
    709711;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    710712;;
    711 ;; decomp-acode
     713;;  For code coverage, pretty-print acode to string and store position info in code notes.
    712714;;
    713 ;;  Decompile acode into something more readable.
    714 ;;  For debugging, but also used for a code coverage feature
    715 
    716 
    717 (defun decomp-acode (acode)
     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 (and *nx-current-code-note* (null (afunc-parent afunc))))
     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    (setf (afunc-lfun-info afunc) (list* '%function-acode-string string (afunc-lfun-info afunc)))
     778    afunc))
     779
     780(defmethod print-object ((ref acode-afunc-ref) stream)
     781  (if (nx-pprinting-p stream)
     782    (let ((index (acode-afunc-ref-index ref)))
     783      (when index ;; referenced multiple times.
     784        (if (eql index 0)  ;; never referenced before?
     785          (format stream "#~d="
     786                  (setf (acode-afunc-ref-index ref) (incf *nx-acode-refs-counter*)))
     787          ;; If not first reference, just point back.
     788          (return-from print-object (format stream "#~d#" index))))
     789      (write-1 (acode-afunc-ref-object ref) stream))
     790    (call-next-method)))
     791
     792(defmethod print-object ((ref acode-ref) stream)
     793  (if (nx-pprinting-p stream)
     794    (write-1 (acode-ref-object ref) stream)
     795    (call-next-method)))
     796
     797(defun decomp-ref (obj)
     798  (if (and (listp *nx-acode-inner-refs*) ;; code coverage case
     799           (not (acode-p obj)))
     800    (make-acode-ref :object obj)
     801    obj))
     802
     803(defvar *decomp-prettify* nil "If true, loses info but results in more recognizable lisp")
     804
     805(defvar *decomp-hook* nil)
     806
     807(defun decomp-acode (acode &key (hook *decomp-hook*) (prettify *decomp-prettify*))
     808  (let ((*decomp-hook* hook)
     809        (*decomp-prettify* prettify))
     810    (decomp-form acode)))
     811
     812(defun decomp-form (acode)
    718813  (cond ((eq acode *nx-t*) t)
    719814        ((eq acode *nx-nil*) nil)
     
    724819                                   (setq op (logand op operator-id-mask))
    725820                                   (< op num))
    726                           (car (nth (- num op 1) *next-nx-operators*)))))
    727              (decomp-using-name (or name op) (cdr acode))))))
    728 
    729 ;; TBD maybe decomp afunc-acode?
     821                          (car (nth (- num op 1) *next-nx-operators*))))
     822                  (new (decomp-using-name (or name op) (cdr acode))))
     823             (when *decomp-hook*
     824               (funcall *decomp-hook* acode new))
     825             new))))
     826
     827
    730828(defun decomp-afunc (afunc)
    731   (require-type afunc 'afunc))
     829  (setq afunc (require-type afunc 'afunc))
     830  (dbg-assert (afunc-acode afunc))
     831  (if (listp *nx-acode-inner-refs*)    ;; code coverage case
     832      (let ((ref (find afunc *nx-acode-inner-refs* :key #'acode-afunc-ref-afunc)))
     833        (if ref ;; seen before, mark that multiply referenced.
     834            (setf (acode-afunc-ref-index ref) 0)
     835            (push (setq ref (make-acode-afunc-ref :afunc afunc
     836                                                  :object (decomp-form (afunc-acode afunc))))
     837                  *nx-acode-inner-refs*))
     838        ref)
     839      afunc))
    732840
    733841(defun decomp-var (var)
    734   (var-name (require-type var 'var)))
     842  (decomp-ref (var-name (require-type var 'var))))
    735843
    736844(defun decomp-formlist (formlist)
    737   (mapcar #'decomp-acode formlist))
     845  (mapcar #'decomp-form formlist))
    738846
    739847(defun decomp-arglist (arglist)
     
    753861          (opts (when opt (cons '&optional (apply #'mapcar
    754862                                                  (lambda (var init supp)
    755                                                     (list (decomp-arg var)
    756                                                           (decomp-acode init)
    757                                                           (and supp (decomp-arg supp))))
     863                                                    (if (and (not supp) (eq init *nx-nil*))
     864                                                      (decomp-arg var)
     865                                                      (list* (decomp-arg var)
     866                                                             (decomp-form init)
     867                                                             (and supp (list (decomp-arg supp))))))
    758868                                                  opt))))
    759869          (rest (when rest (list '&rest (decomp-arg rest))))
     
    763873                     (when vars
    764874                       (cons '&key (map 'list (lambda (var supp init key)
    765                                                 (list* (list key (decomp-arg var))
    766                                                        (decomp-acode init)
    767                                                        (and supp (list (decomp-arg supp)))))
     875                                                (let* ((sym (decomp-arg var))
     876                                                       (arg (if (and (symbolp sym) (eq (make-keyword sym) key))
     877                                                              sym
     878                                                              (list key sym))))
     879                                                  (if (and (not supp) (eq init *nx-nil*) (eq arg sym))
     880                                                    sym
     881                                                    (list* arg
     882                                                           (decomp-form init)
     883                                                           (and supp (list (decomp-arg supp)))))))
    768884                                        vars supps inits keyvect)))
    769885                     (when aok (list '&allow-other-keys))))))
     
    771887                   (cons '&aux (apply #'mapcar
    772888                                      (lambda (var init)
    773                                         (list (decomp-arg var) (decomp-acode init)))
     889                                        (if (eq init *nx-nil*)
     890                                          (decomp-arg var)
     891                                          (list (decomp-arg var) (decomp-form init))))
    774892                                      auxen)))))
    775893      (nconc whole reqs opts rest keys auxen))))
     
    805923
    806924(defdecomp immediate (op imm)
    807   (declare (ignore op))
    808   `',imm)
     925  (when *decomp-prettify*
     926    (setq op 'quote))
     927  `(,op ,imm))
    809928
    810929(defdecomp fixnum (op raw-fixnum)
    811930  (declare (ignore op))
    812   raw-fixnum)
     931  (decomp-ref raw-fixnum))
    813932
    814933(defdecomp %function (op symbol)
    815   (declare (ignore op))
    816   `(function ,symbol))
     934  (when *decomp-prettify*
     935    (setq op 'function))
     936  `(,op ,symbol))
    817937
    818938(defdecomp simple-function (op afunc)
    819   (declare (ignore op))
    820   `(quote ,(decomp-afunc afunc)))
     939  (when *decomp-prettify*
     940    (setq op 'function))
     941  `(,op ,(decomp-afunc afunc)))
    821942
    822943(defdecomp closed-function (op afunc)
     944  (when *decomp-prettify*
     945    (setq op 'function))
    823946  `(,op ,(decomp-afunc afunc)))
    824947
     
    827950
    828951(defdecomp multiple-value-call (op fn form-list)
    829   `(,op ,(decomp-acode fn) ,@(decomp-formlist form-list)))
     952  `(,op ,(decomp-form fn) ,@(decomp-formlist form-list)))
    830953
    831954(defdecomp vector (op formlist)
     
    839962           (op target argspecs argvals resultspec &rest rest)
    840963  `(,op
    841     ,(decomp-acode target)
    842     ,@(mapcan (lambda (spec val) (list spec (decomp-acode val))) argspecs argvals)
     964    ,(decomp-form target)
     965    ,@(mapcan (lambda (spec val) (list spec (decomp-form val))) argspecs argvals)
    843966    ,resultspec
    844967    ,@rest))
     
    847970  (if (eq (acode-immediate-operand cc) :eq)
    848971    `(,op ,@(decomp-formlist forms))
    849     `(,op ,(decomp-acode cc) ,@(decomp-formlist forms))))
     972    `(,op ,(decomp-form cc) ,@(decomp-formlist forms))))
    850973
    851974(defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p)
    852   `(,op ',typespec ,(decomp-acode form) ,check-p))
     975  `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p))))
    853976
    854977(defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p)
    855   `(,op ,(decomp-acode form1) ,(decomp-acode form2) ,overflow-p))
     978  `(,op ,(decomp-form form1) ,(decomp-form form2) ,overflow-p))
    856979
    857980(defdecomp (immediate-get-xxx %immediate-set-xxx) (op bits &rest forms)
     
    859982
    860983(defdecomp call (op fn arglist &optional spread-p)
    861   (declare (Ignore op))
    862   `(,(if spread-p 'apply 'funcall) ,(decomp-acode fn) ,@(decomp-arglist arglist)))
     984  (setq op (if spread-p 'apply 'funcall))
     985  `(,op ,(decomp-form fn) ,@(decomp-arglist arglist)))
    863986
    864987(defdecomp lexical-function-call (op afunc arglist &optional spread-p)
    865   (declare (Ignore op))
    866   `(,(if spread-p 'apply 'funcall) ,(decomp-afunc afunc) ,@(decomp-arglist arglist)))
     988  (setq op (if *decomp-prettify*
     989             (if spread-p 'apply 'funcall)
     990             (if spread-p 'lexical-apply 'lexical-funcall)))
     991  `(,op ,(decomp-afunc afunc) ,@(decomp-arglist arglist)))
    867992
    868993(defdecomp self-call (op arglist &optional spread-p)
     
    871996
    872997(defdecomp (free-reference special-ref bound-special-ref global-ref) (op symbol)
    873   `(,op ,symbol))
     998  (if *decomp-prettify*
     999    (decomp-ref symbol)
     1000    `(,op ,symbol)))
    8741001
    8751002(defdecomp (setq-special setq-free global-setq) (op symbol form)
    876   `(,op ,symbol ,(decomp-acode form)))
    877 
    878 (defdecomp (inherited-arg lexical-reference setq-lexical) (op var &rest forms)
    879   `(,op ,(decomp-var var) ,@(decomp-formlist forms)))
    880 
     1003  (when *decomp-prettify*
     1004    (setq op 'setq))
     1005  `(,op ,symbol ,(decomp-form form)))
     1006
     1007(defdecomp inherited-arg (op var)
     1008  `(,op ,(decomp-var var)))
     1009
     1010(defdecomp lexical-reference (op var)
     1011  (if *decomp-prettify*
     1012    (decomp-var var)
     1013    `(,op ,(decomp-var var))))
     1014
     1015(defdecomp setq-lexical (op var form)
     1016  (when *decomp-prettify*
     1017    (setq op 'setq))
     1018  `(,op ,(decomp-var var) ,(decomp-form form)))
    8811019
    8821020(defdecomp (let let* with-downward-closures) (op vars vals body p2decls)
    8831021  (declare (ignore p2decls))
    884   `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-acode val))) vars vals)
    885     ,(decomp-acode body)))
     1022  `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-form val))) vars vals)
     1023    ,(decomp-form body)))
    8861024
    8871025(defdecomp %decls-body (op form p2decls)
    8881026  (declare (ignore p2decls))
    889   `(,op ,(decomp-acode form)))
     1027  `(,op ,(decomp-form form)))
    8901028
    8911029(defdecomp multiple-value-bind (op vars form body p2decls)
    8921030  (declare (ignore p2decls))
    893   `(,op ,(mapcar #'decomp-var vars) ,(decomp-acode form) ,(decomp-acode body)))
     1031  `(,op ,(mapcar #'decomp-var vars) ,(decomp-form form) ,(decomp-form body)))
    8941032
    8951033
    8961034(defdecomp lambda-list (op req opt rest keys auxen body p2decls &optional code-note)
    8971035  (declare (ignore p2decls code-note))
    898   `(lambda-list ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-acode body)))
     1036  (when *decomp-prettify*
     1037    (setq op 'lambda))
     1038  `(,op ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-form body)))
    8991039
    9001040(defdecomp debind (op ll form req opt rest keys auxen whole body p2decls cdr-p)
    9011041  (declare (ignore ll p2decls cdr-p))
    902   `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-acode form) ,(decomp-acode body)))
     1042  `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-form form) ,(decomp-form body)))
    9031043
    9041044(defdecomp lambda-bind (op vals req rest keys-p auxen body p2decls)
     
    9091049                        (mapcar (lambda (x) (if (fixnump x) `(keyref ,x) x)) vals)))))
    9101050  (let ((lambda-list (decomp-lambda-list req nil rest nil  auxen)))
    911     `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-acode body))))
     1051    `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-form body))))
    9121052
    9131053(defdecomp (flet labels) (op vars afuncs body p2decls)
     
    9161056                            (list (decomp-var var) (decomp-afunc afunc)))
    9171057                          vars afuncs)
    918     ,(decomp-acode body)))
     1058    ,(decomp-form body)))
    9191059
    9201060(defdecomp local-go (op tag)
     1061  (when *decomp-prettify*
     1062    (setq op 'go))
    9211063  `(,op ,(car tag)))
    9221064
    9231065(defdecomp tag-label (op &rest tag)
    924   `(,op ,(car tag)))
     1066  (if *decomp-prettify*
     1067    (decomp-ref (car tag))
     1068    `(,op ,(car tag))))
    9251069
    9261070(defdecomp local-tagbody (op tags forms)
    9271071  (declare (ignore tags))
     1072  (when *decomp-prettify*
     1073    (setq op 'tagbody))
    9281074  `(,op ,@(decomp-formlist forms)))
    9291075
    9301076(defdecomp local-block (op block body)
    931   `(,op ,(car block) ,(decomp-acode body)))
     1077  (when *decomp-prettify*
     1078    (setq op 'block))
     1079  `(,op ,(car block) ,(decomp-form body)))
    9321080
    9331081(defdecomp local-return-from (op block form)
    934   `(,op ,(car block) ,(decomp-acode form)))
     1082  (when *decomp-prettify*
     1083    (setq op 'return-from))
     1084  `(,op ,(car block) ,(decomp-form form)))
    9351085
    9361086; end
  • trunk/source/compiler/nx0.lisp

    r13890 r13966  
    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"))
     
    14721464    (setf (afunc-vcells p) *nx1-vcells*)
    14731465    (setf (afunc-fcells p) *nx1-fcells*)
     1466    (when *nx-current-code-note*
     1467      (when (null q) ;; toplevel functions only
     1468        (nx-record-code-coverage-acode p)))
    14741469    (let* ((warnings (merge-compiler-warnings *nx-warnings*))
    14751470           (name *nx-cur-func-name*))       
Note: See TracChangeset for help on using the changeset viewer.