Commit 3df5023f authored by Matthew Steele's avatar Matthew Steele

Lots of changes and improvements, including:

  - Added instrumentation for #. and #S
  - Potentially dangerous heuristics for defvar and defconstant
  - Improved handler for defstruct
  - New unit tests
  - Some cleanup of old code
parent e6bdb949
...@@ -29,13 +29,13 @@ to the base of the system." ...@@ -29,13 +29,13 @@ to the base of the system."
;; Used only by with-dependency-tracking. ;; Used only by with-dependency-tracking.
(defun call-with-dependency-tracking (comp thunk) (defun call-with-dependency-tracking (comp thunk)
;; (if *using-constituents* (if *current-constituent*
(if *current-constituent* (operating-on-asdf-component-constituent (comp)
(operating-on-asdf-component-constituent (comp) ;((merge-pathnames (asdf:component-pathname comp)))
;((merge-pathnames (asdf:component-pathname comp))) (with-groveling-readtable
(with-groveling-macroexpand-hook (with-groveling-macroexpand-hook
(funcall thunk))) (funcall thunk))))
(funcall thunk))) (funcall thunk)))
;; (if *current-dependency-state* ;; (if *current-dependency-state*
;; (operating-on-component (comp) ;; (operating-on-component (comp)
;; (let ((file (namestring (merge-pathnames ;; (let ((file (namestring (merge-pathnames
......
This diff is collapsed.
This diff is collapsed.
...@@ -47,25 +47,75 @@ ...@@ -47,25 +47,75 @@
;;;;;;;;;;;;;;;;;;;;;;;;;; Variable-Related Handlers ;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;; Variable-Related Handlers ;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (defvar *adg-specials* (make-hash-table :test 'eql))
;; (defun special-substitute-name (name)
;; (or (gethash name *adg-specials*)
;; (setf (gethash name *adg-specials*)
;; (gentemp (format nil "ASDF-DEPENDENCY-GROVEL-SPECIAL--~A" name)))))
;; ;; When we hit a declaim, we need to watch out for special variable
;; ;; declarations (all other declarations can be left as-is). Once a name is
;; ;; declared special, it can no longer be defined as a symbol macro; thus,
;; ;; without this handler, things will break if someone declares a name special
;; ;; before defvar-ing that name.
;; (define-macroexpand-handlers (form :function fun :environment env)
;; (declaim)
;; (destructuring-bind (dec &rest claims) form
;; (loop :for claim :in claims :with new-names := nil
;; :if (equal (string (car claim)) "SPECIAL")
;; :do (setf new-names (mapcar #'special-substitute-name (cdr claim)))
;; :and :collect (cons (car claim) new-names)
;; :into new-claims
;; :and :append (let ((*macroexpand-hook* *old-macroexpand-hook*))
;; (loop :for name :in (cdr claim)
;; :for new-name :in new-names
;; :collect (macroexpand-1
;; `(define-symbol-macro ,name
;; (signal-variable-use ',name 'defvar
;; ',new-name)))))
;; :into epilogue
;; :else
;; :collect claim :into new-claims
;; :finally (return (does-macroexpand-with-epilogue (fun env)
;; (cons dec new-claims)
;; (nconc epilogue (list '(values))))))))
(define-macroexpand-handlers (form) (define-macroexpand-handlers (form)
(defvar defparameter) (defvar defparameter)
(signal-provider (second form) 'defvar) (destructuring-bind (def name &rest rest) form
;; (unless *using-constituents* (hashset-add name *suspected-variables*)
;; (setf (gethash (second form) *suspected-variables*) t)) (signal-provider name 'defvar)
(does-not-macroexpand)) ;; (let ((new-name (special-substitute-name name)))
;; ;; (new-name (gentemp (format nil "ASDF-DEPENDENCY-GROVEL-DEFVAR--~A"
;; ;; name))))
;; (does-macroexpand-with-prologue (fun env)
;; ;; Do a little dance to prevent ADG from thinking that this form is
;; ;; providing a symbol macro. Probably a better solution would be to
;; ;; change does-macroexpand-with-prologue (and
;; ;; does-macroexpand-with-epilogue, while we're at it) to not apply
;; ;; handlers to the prologue/epilogue.
;; (let ((*macroexpand-hook* *old-macroexpand-hook*))
;; (list (macroexpand-1
;; `(define-symbol-macro ,name
;; (signal-variable-use ',name 'defvar ',new-name)))))
;; ;; Do the original defvar/defparameter, but with the new name.
;; `(,def ,new-name ,@rest)))))
(does-not-macroexpand)))
(define-macroexpand-handlers (form :environment env) (define-macroexpand-handlers (form :environment env)
(defconstant) (defconstant)
(let ((symbol (second form))) (let ((symbol (second form)))
(signal-provider (second form) (first form)) (signal-provider (second form) 'defconstant)
(if t ;; set to nil to disable defconstant instrumentation (hashset-add (second form) *suspected-constants*)
(does-macroexpand-with-epilogue ;; (does-macroexpand-with-epilogue
((macro-function 'symbol-macroify) env) ;; ((macro-function 'symbol-macroify) env)
`(symbol-macroify ,@form) ;; `(symbol-macroify ,@form)
`((eval-when (:compile-toplevel :load-toplevel :execute) ;; `((eval-when (:compile-toplevel :load-toplevel :execute)
(setf (symbol-value ',symbol) ,symbol)) ;; (setf (symbol-value ',symbol) ,symbol))
',symbol)) ;; ',symbol))
(does-not-macroexpand)))) (does-not-macroexpand)))
;;;;;;;;;;;;;;;;;;;;;;;;;;; Macro-Related Handlers ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;; Macro-Related Handlers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
...@@ -79,7 +129,7 @@ ...@@ -79,7 +129,7 @@
(define-macroexpand-handlers (form :function fun :environment env) (define-macroexpand-handlers (form :function fun :environment env)
(define-symbol-macro) (define-symbol-macro)
(destructuring-bind (def name expansion) form (destructuring-bind (def name expansion) form
(signal-provider name def) (signal-provider name 'define-symbol-macro)
(does-macroexpand (fun env) (does-macroexpand (fun env)
`(,def ,name (signal-symbol-macroexpansion ',name ,expansion))))) `(,def ,name (signal-symbol-macroexpansion ',name ,expansion)))))
...@@ -190,7 +240,12 @@ ...@@ -190,7 +240,12 @@
(if (listp header) header (list header)) (if (listp header) header (list header))
;; Provide the class and type for this struct. ;; Provide the class and type for this struct.
(signal-provider name 'defclass) (signal-provider name 'defclass)
(signal-provider (second form) 'deftype) (signal-provider name 'defstruct)
(signal-provider name 'deftype)
;; Check for an :include struct option.
(let ((include-option (assoc :include struct-options)))
(when include-option
(signal-user (second include-option) 'defstruct)))
;; Deal with accessor functions. The defstruct macro automatically ;; Deal with accessor functions. The defstruct macro automatically
;; defines a whole bunch of accessor functions, which we must ;; defines a whole bunch of accessor functions, which we must
;; "retroactively" instrument. In particular, we must "manually" ;; "retroactively" instrument. In particular, we must "manually"
...@@ -362,18 +417,55 @@ ...@@ -362,18 +417,55 @@
:do (cond :do (cond
((consp setee) ((consp setee)
(signal-user (first setee) 'setf)) (signal-user (first setee) 'setf))
((and (symbolp setee) (boundp setee)) #|((and (symbolp setee) (boundp setee))
(signal-user setee 'defvar) (signal-user setee 'defvar)
(signal-provider setee 'defvar)))) (signal-provider setee 'defvar))|#)
(when (hashset-contains-p setee *suspected-variables*)
(push (list (first form)
setee
(constituent-summary *current-constituent*))
*global-mutations*)))
(does-not-macroexpand)) (does-not-macroexpand))
(define-macroexpand-handlers (form) (define-macroexpand-handlers (form :function fun :environment env)
(pushnew push) (pushnew push)
(let ((setee (third form))) (let ((setee (third form)))
(when (and (symbolp setee) (boundp setee)) (when (hashset-contains-p setee *suspected-variables*)
(signal-user setee 'defvar) (push (list (first form)
(signal-provider setee 'defvar)))) setee
(constituent-summary *current-constituent*))
*global-mutations*))
(does-not-macroexpand)))
;; (define-macroexpand-handlers (form :function fun :environment env)
;; (pushnew push)
;; (let ((setee (third form)))
;; (if (hashset-contains-p setee *suspected-variables*)
;; (with-gensyms (old-version new-version)
;; (assert (symbolp setee))
;; (does-macroexpand-with-prologue (fun env)
;; `((let* ((,old-version (gethash ,setee *variable-versions*))
;; (,new-version (1+ ,old-version)))
;; (signal-user (cons ,setee ,old-version) 'var-version)
;; (signal-provider (cons ,setee ,new-version) 'var-version)
;; (setf (gethash ,setee *variable-versions*) ,new-version)))
;; form))
;; (let* ((old-version (gethash setee *variable-versions*))
;; (new-version (1+ old-version)))
;; (signal-user (cons setee old-version) 'var-version)
;; (signal-provider (cons setee new-version) 'var-version)
;; (setf (gethash setee *variable-versions*) new-version)
;; )
;; (does-not-macroexpand))))
;; (define-macroexpand-handlers (form)
;; (pushnew push)
;; (let ((setee (third form)))
;; (when (and (symbolp setee) (boundp setee))
;; (signal-user setee 'defvar)
;; (signal-provider setee 'defvar))))
(define-macroexpand-handlers (form :function fun :environment env) (define-macroexpand-handlers (form :function fun :environment env)
......
...@@ -19,9 +19,7 @@ ...@@ -19,9 +19,7 @@
#:instrumented-load #:instrumented-load
#:instrumented-compile-file #:instrumented-compile-file
#:fine-grain-instrumented-load #:fine-grain-instrumented-load
#:print-big-ol-dependency-report #:print-big-ol-dependency-report))
;; Feature set when groveling:
#:groveling))
(cl:defpackage #:asdf-dependency-grovel.packages (cl:defpackage #:asdf-dependency-grovel.packages
(:use)) (:use))
......
(cl:in-package :asdf-dependency-grovel-test)
(defvar *p-defvar-variable* 42)
(defparameter *p-defvar-varlist* nil)
...@@ -9,6 +9,9 @@ ...@@ -9,6 +9,9 @@
(:file "p-define-method-combination") (:file "p-define-method-combination")
(:file "p-feature") (:file "p-feature")
;; defvar
(:file "p-defvar")
;; setf ;; setf
(:file "p-define-setf-expander") (:file "p-define-setf-expander")
(:file "p-defsetf") (:file "p-defsetf")
...@@ -39,6 +42,12 @@ ...@@ -39,6 +42,12 @@
(:file "u-define-method-combination") (:file "u-define-method-combination")
(:file "u-feature") (:file "u-feature")
;; defvar
(:file "u-defvar")
(:file "u-defvar.vector")
(:file "u-defvar.setf")
(:file "u-defvar.push")
;; setf ;; setf
(:file "u-define-setf-expander") (:file "u-define-setf-expander")
(:file "u-defsetf") (:file "u-defsetf")
...@@ -56,6 +65,7 @@ ...@@ -56,6 +65,7 @@
(:file "u-defstruct.defmethod") (:file "u-defstruct.defmethod")
(:file "u-defstruct.functions") (:file "u-defstruct.functions")
(:file "u-defstruct.functions.sharpquote") (:file "u-defstruct.functions.sharpquote")
(:file "u-defstruct.include")
;; package system ;; package system
(:file "u-defpackage") (:file "u-defpackage")
......
(cl:in-package :asdf-dependency-grovel-test) (cl:in-package :asdf-dependency-grovel-test)
(eval-when (:compile-toplevel) (eval-when (:compile-toplevel)
(test-defstruct/function-a *function-defstruct*)) (defvar *function-defstruct-2* (make-test-defstruct/function :a 2 :b 3 :c 4))
(test-defstruct/function-a *function-defstruct-2*))
(cl:in-package :asdf-dependency-grovel-test)
(defstruct (test-defstruct/function-extended
(:include test-defstruct/function))
"This is a docstring."
d e)
(cl:in-package :asdf-dependency-grovel-test) (cl:in-package :asdf-dependency-grovel-test)
(defvar *function-defstruct* (make-test-defstruct/function :a 2 :b 3 :c 4)) (defvar *function-defstruct-1* (make-test-defstruct/function :a 2 :b 3 :c 4))
(test-defstruct/function-a *function-defstruct*) (test-defstruct/function-a *function-defstruct-1*)
(cl:in-package :asdf-dependency-grovel-test)
(defparameter *u-defvar-variable* (+ 2 *p-defvar-variable*))
(cl:in-package :asdf-dependency-grovel-test)
(push 7 *p-defvar-varlist*)
(cl:in-package :asdf-dependency-grovel-test)
(setf *p-defvar-variable* 45)
(cl:in-package :asdf-dependency-grovel-test)
(defparameter *u-defvar-variable* #(1 2 *p-defvar-variable* 3))
#+xcvb (module (:depends-on ("package"))) #+xcvb (module (:depends-on ("package")))
(cl:in-package #:asdf-dependency-grovel) (in-package #:asdf-dependency-grovel)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Debugging ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *debug-trace* nil
"When non-nil, enables all kinds of output for debugging ADG.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Macro Expansion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Macro Expansion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
...@@ -10,15 +15,38 @@ ...@@ -10,15 +15,38 @@
"When the override macroexpand hook is active, this is bound to the old value "When the override macroexpand hook is active, this is bound to the old value
of *macroexpand-hook*.") of *macroexpand-hook*.")
(defvar *preprocess-form-p* t
"Used to let the groveling-macroexpand-hook know when it needs to preprocess
a form before macroexpanding it. It starts out as t, but is bound to nil
within the instrumented-eval function.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Constituent Stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *current-constituent* nil
"The lowest-level constituent that we are currently inside.")
(defvar *constituent-table* nil
"Hash table mapping constituent designators to constituent objects
(initialized by with-constituent-groveling).")
;;;;;;;;;;;;;;;;;;;;;;;;;; Global Variable Tracking ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *suspected-variables* nil
"Hash table containing the symbols that should be treated as if they were
variables (as if by defvar/defparameter) when used in forms.")
(defvar *suspected-constants* nil
"Hash table containing the symbols that should be treated as if they were
constants (as if by defconstant) when used in forms.")
(defvar *global-mutations* nil
"Experimental -- likely to be removed in the future. (msteele)")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ASDF Stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ASDF Stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (defvar *current-component* nil ;; (defvar *current-component* nil
;; "The currently loaded/compiled ASDF component") ;; "The currently loaded/compiled ASDF component")
;; (defvar *suspected-variables* nil
;; "Hash table containing the symbols that should be treated as if they were
;; variables when used in forms.")
;; (defvar *current-dependency-state* nil ;; (defvar *current-dependency-state* nil
;; "The state of dependency information for the current groveling run.") ;; "The state of dependency information for the current groveling run.")
...@@ -96,23 +124,4 @@ ...@@ -96,23 +124,4 @@
signal-internal-symbols becomes a no-op, and the defpackage and in-package signal-internal-symbols becomes a no-op, and the defpackage and in-package
handlers do less work.") handlers do less work.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Constituent Stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Added by msteele:
;; (defvar *non-asdf-p* nil
;; "When nil, assumes we're groveling ASDF-based code.
;; When non-nil, assumes we're groveling non-ASDF-based code.")
;; (defvar *using-constituents* nil
;; "When nil, assumes we're using the old representations.
;; When non-nil, assumes we're using constituents.")
(defvar *current-constituent* nil
"The lowest-level constituent that we are currently inside.")
(defvar *constituent-table* nil
"Hash table mapping constituent designators to constituent objects
(initialized by with-constituent-groveling).")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment