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

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

Location:
branches/qres/ccl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • 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
Note: See TracChangeset for help on using the changeset viewer.