Commit 897ad166 authored by Matthew Steele's avatar Matthew Steele

Lots of code cleanup/reorganization. Commented out some unused code.

parent 669857de
......@@ -25,6 +25,9 @@ to the base of the system."
system-base-dir)
output-file))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Dependency Tracking ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Used only by with-dependency-tracking.
(defun call-with-dependency-tracking (comp thunk)
(if *current-dependency-state*
(operating-on-component (comp)
......@@ -36,19 +39,24 @@ to the base of the system."
(signal-new-internal-symbols)))))
(funcall thunk)))
;; Exported. Also used by emit-perform-method.
(defmacro with-dependency-tracking (comp &body body)
`(call-with-dependency-tracking ,comp #'(lambda () ,@body)))
(macrolet ((emit-perform-method (op-type)
`(defmethod asdf:perform :around ((op ,op-type)
(comp instrumented-cl-source-file))
`(defmethod asdf:perform :around
((op ,op-type)
(comp instrumented-cl-source-file))
(with-dependency-tracking comp (call-next-method)))))
(emit-perform-method asdf:load-op)
(emit-perform-method asdf:compile-op))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TODO for asdf-component/op:
;;; * ignore component-name. I have no idea what it /should/ indicate.
;; Used by XCVB:
(defclass component-file (asdf:source-file)
((last-grovel-state :initform nil)
(load-system :initarg :load-systems)
......@@ -59,18 +67,17 @@ to the base of the system."
(base-pathname :initarg :base-pathname)
(debug-object-types :initarg :debug-object-types :initform nil)
(base-asd-file :initarg :base-asd-file :initform nil)
(additional-initargs :initarg :additional-initargs :initform nil
:documentation
#.(format nil "A list of mappings from ~
components in systems to additional initargs that the ~
instrumented components should receive. E.g.:
((:foo-system (\"module\" \"component-name\") :additional-dependencies ())
(:foo-system (\"component2\") :data-files ())"))))
(defclass dependency-op (asdf:operation)
())
(additional-initargs
:initarg :additional-initargs :initform nil
:documentation
#.(format nil "A list of mappings from ~
components in systems to additional initargs that the ~
instrumented components should receive. E.g.:
((:foo-system (\"module\" \"component-name\") :additional-dependencies ())
(:foo-system (\"component2\") :data-files ())"))))
(defclass compare-dependency-op (dependency-op) ())
;; Used by XCVB.
(defclass dependency-op (asdf:operation) ())
(defun state-of (op component)
(declare (ignore op))
......@@ -93,12 +100,6 @@ to the base of the system."
;; XXX: base-pathname?
(list (asdf:component-pathname c)))
(defmethod asdf:input-files ((op compare-dependency-op) (c component-file))
(append (call-next-method) (list (slot-value c 'base-asd-file))))
(defmethod asdf:output-files ((op compare-dependency-op) (c component-file))
(append (call-next-method) (list (slot-value c 'output-file))))
(defmethod asdf:operation-done-p ((op dependency-op) (comp component-file))
nil)
......@@ -114,6 +115,7 @@ to the base of the system."
*default-component-class*
what-would-asdf-do)))
;; Used by asdf:perform.
(defun load-instrumented-systems (systems additional-initargs)
(let ((*default-component-class* (find-class 'instrumented-cl-source-file)))
(flet ((reload-system (system)
......@@ -123,7 +125,8 @@ to the base of the system."
(labels ((find-component-in-module (module components)
(if (null (rest components))
(asdf:find-component module (first components))
(find-component-in-module (asdf:find-component module (first components))
(find-component-in-module (asdf:find-component
module (first components))
(rest components))))
(add-initargs (system compspec args)
(let ((component (find-component-in-module
......@@ -134,7 +137,8 @@ to the base of the system."
compspec system)
(apply #'reinitialize-instance component args))))
(loop for (system compspec . initargs) in additional-initargs
do (assert (member (asdf::coerce-name system) systems :key #'asdf::coerce-name
do (assert (member (asdf::coerce-name system) systems
:key #'asdf::coerce-name
:test #'equal)
()
"Component translation in System ~A which is not a member of the ~
......@@ -153,69 +157,41 @@ to the base of the system."
(with-slots (load-system merge-systems
component-name-translation cull-redundant verbose
additional-initargs base-pathname debug-object-types) c
(let ((base-pathname (or (and (slot-boundp c 'base-pathname)
base-pathname)
(truename
(make-pathname :name nil
:type nil
:defaults
(asdf:component-pathname c))))))
(let ((base-pathname
(or (and (slot-boundp c 'base-pathname)
base-pathname)
(truename (make-pathname :name nil
:type nil
:defaults
(asdf:component-pathname c))))))
(load-instrumented-systems merge-systems additional-initargs)
(setf (state-of op c)
(if (state-of op c)
(re-grovel-dependencies (mapcar #'asdf:find-system
(if (consp load-system)
load-system
(list load-system)))
component-stream
(mapcar #'asdf:find-system merge-systems)
(state-of op c)
:verbose verbose
:debug-object-types debug-object-types
:base-pathname base-pathname)
(initially-grovel-dependencies (mapcar #'asdf:find-system
(if (consp load-system)
load-system
(list load-system)))
component-stream
(mapcar #'asdf:find-system merge-systems)
:verbose verbose
:cull-redundant cull-redundant
:debug-object-types debug-object-types
:base-pathname base-pathname))))))
(error "I refuse to re-grovel.")
;; (re-grovel-dependencies
;; (mapcar #'asdf:find-system
;; (if (consp load-system)
;; load-system
;; (list load-system)))
;; component-stream
;; (mapcar #'asdf:find-system merge-systems)
;; (state-of op c)
;; :verbose verbose
;; :debug-object-types debug-object-types
;; :base-pathname base-pathname)
(initially-grovel-dependencies
(mapcar #'asdf:find-system
(if (consp load-system)
load-system
(list load-system)))
component-stream
(mapcar #'asdf:find-system merge-systems)
:verbose verbose
:cull-redundant cull-redundant
:debug-object-types debug-object-types
:base-pathname base-pathname))))))
(rename-file tmp-file-name (first (asdf:output-files op c)))))
(defmethod asdf:perform ((op compare-dependency-op) (c component-file))
;; not incremental yet (but it's mostly useless anyway for large systems?)
(with-slots (load-system merge-systems base-asd-file output-file
component-name-translation cull-redundant verbose
additional-initargs base-pathname debug-object-types) c
(let* ((base-pathname (or (and (slot-boundp c 'base-pathname)
base-pathname)
(truename
(make-pathname :name nil
:type nil
:defaults
(asdf:component-pathname c)))))
(out-pathname (pathname (first (asdf:output-files op c))))
(tmp-pathname (make-pathname
:name (format nil "~A-~A" (pathname-name out-pathname) (get-universal-time))
:defaults out-pathname)))
(load-instrumented-systems merge-systems additional-initargs)
(prog1
(grovel-and-compare-dependencies (mapcar #'asdf:find-system
(if (consp load-system)
load-system
(list load-system)))
base-asd-file
(mapcar #'asdf:find-system merge-systems)
:output tmp-pathname
:verbose verbose
:cull-redundant cull-redundant
:debug-object-types debug-object-types
:base-pathname base-pathname))
(rename-file tmp-pathname out-pathname))))
;;; Reading the component list back into asdf defsystems
(macrolet
......@@ -250,3 +226,50 @@ to the base of the system."
(define-comp-file-reader systems-in-configuration (system component-names)
(when system
(push (first system) component-names))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; Unused.
;; (defclass compare-dependency-op (dependency-op) ())
;; ;; Unused.
;; (defmethod asdf:input-files ((op compare-dependency-op) (c component-file))
;; (append (call-next-method) (list (slot-value c 'base-asd-file))))
;; ;; Unused.
;; (defmethod asdf:output-files ((op compare-dependency-op) (c component-file))
;; (append (call-next-method) (list (slot-value c 'output-file))))
;; ;; Unused.
;; (defmethod asdf:perform ((op compare-dependency-op) (c component-file))
;; ;; not incremental yet (but it's mostly useless anyway for large systems?)
;; (with-slots (load-system merge-systems base-asd-file output-file
;; component-name-translation cull-redundant verbose
;; additional-initargs base-pathname debug-object-types) c
;; (let* ((base-pathname (or (and (slot-boundp c 'base-pathname)
;; base-pathname)
;; (truename
;; (make-pathname :name nil
;; :type nil
;; :defaults
;; (asdf:component-pathname c)))))
;; (out-pathname (pathname (first (asdf:output-files op c))))
;; (tmp-pathname (make-pathname
;; :name (format nil "~A-~A" (pathname-name out-pathname) (get-universal-time))
;; :defaults out-pathname)))
;; (load-instrumented-systems merge-systems additional-initargs)
;; (prog1
;; (grovel-and-compare-dependencies (mapcar #'asdf:find-system
;; (if (consp load-system)
;; load-system
;; (list load-system)))
;; base-asd-file
;; (mapcar #'asdf:find-system merge-systems)
;; :output tmp-pathname
;; :verbose verbose
;; :cull-redundant cull-redundant
;; :debug-object-types debug-object-types
;; :base-pathname base-pathname))
;; (rename-file tmp-pathname out-pathname))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
This diff is collapsed.
......@@ -3,7 +3,7 @@
(cl:defpackage #:asdf-dependency-grovel
(:use #:cl)
(:export #:reload
#:component-file #:dependency-op #:compare-dependency-op
#:component-file #:dependency-op ;#:compare-dependency-op
#:instrumented-cl-source-file
#:instrumented-module
#:instrumented-component #:additional-initargs
......@@ -15,8 +15,9 @@
;; feature set when groveling:
#:groveling
;; Added by msteele:
;#:with-non-asdf-groveling
#:instrumented-load #:instrumented-compile-file
#:with-non-asdf-groveling #:print-big-ol-dependency-report))
#:print-big-ol-dependency-report))
(cl:defpackage #:asdf-dependency-grovel.packages
(:use))
......
......@@ -61,5 +61,6 @@
failed))
(length failed)))
(defun check-base-deps ()
(asdf:oos 'asdf-dependency-grovel:compare-dependency-op :test-serial))
\ No newline at end of file
;; Currently unused (commented out in the test script).
;; (defun check-base-deps ()
;; (asdf:oos 'asdf-dependency-grovel:compare-dependency-op :test-serial))
......@@ -33,6 +33,7 @@
(defvar *component-dependency-op-times* (make-hash-table)
"Maps components to the last universal-time they were groveled.")
;; Used by XCVB:
(defvar *system-base-dir* nil
"Designates the directory under which ADG will create its temporary directory
for instrumented dependency-discovery FASLs.
......
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