Newer
Older
#+xcvb (module (:depends-on ("grain-interface" "dependencies-interpreter")))
(declaim (optimize (speed 2) (safety 3) (debug 3) (compilation-speed 0)))
(defclass enforcing-traversal (traversal)
())
(defclass static-traversal (enforcing-traversal)
Francois-Rene Rideau
committed
:initform (make-hashset :test 'equal)
Francois-Rene Rideau
committed
:accessor included-dependencies
:documentation "dependencies included in the current world, as a set")
(linking-traversal-p
:initform nil
:accessor linking-traversal-p
:documentation "is this traversal for linking")
(issued-build-commands
:accessor issued-build-commands
:documentation "load commands issued so far to build the current world, as a set")
(build-commands-r
:initform nil
:accessor traversed-build-commands-r
:documentation "load commands issued so far to build the current world, in reverse order")))
(defmethod print-object ((x static-traversal) stream)
(print-unreadable-object (x stream :type t :identity nil)
(format stream ":target ~S :depth ~A :setup ~S :build-commands ~S :dependencies ~S :linking ~A"
(first (traversed-grain-names-r x))
(length (traversed-grain-names-r x))
(if (slot-boundp x 'image-setup) (image-setup x) :no-image-setup)
(reverse (traversed-build-commands-r x))
(mapcar 'fullname (reverse (traversed-dependencies-r x)))
(linking-traversal-p x))))
(defmethod tweak-dependency ((env static-traversal) dep)
(if (linking-traversal-p env)
(linkable-dependency dep)
dep))
(defun tweak-dependencies (env deps)
(mapcar/ #'tweak-dependency env deps))
(defmethod dependency-already-included-p ((env static-traversal) grain)
Francois-Rene Rideau
committed
(or (gethash grain (included-dependencies env))
(call-next-method)))
(defmethod issue-build-command ((env static-traversal) command)
(unless (gethash command (issued-build-commands env))
(setf (gethash command (issued-build-commands env)) t)
(push command (traversed-build-commands-r env))))
(defun graph-for-compiled (env spec)
(graph-for env (compiled-dependency spec)))
(defmethod graph-for-atom (env name)
(graph-for env `(:lisp ,name)))
Francois-Rene Rideau
committed
(defun include-image-dependencies (env image)
Francois-Rene Rideau
committed
(when image
(check-type image image-grain)
(when (linking-traversal-p env)
(assert (null (traversed-build-commands-r env)))
(setf (traversed-build-commands-r env)
(all-build-commands-r env image)))
Francois-Rene Rideau
committed
(setf (included-dependencies env)
(make-hashset :test 'equal :set (included-dependencies image)))))
Francois-Rene Rideau
committed
(define-graph-for :lisp ((env static-traversal) name)
(let* ((grain (resolve-absolute-module-name name)))
(error "Couldn't resolve ~S to a lisp module" name))
(define-graph-for :compile-build (env name)
(graph-for-build-named env name))
(defmethod graph-for-build-named (env name)
Francois-Rene Rideau
committed
(graph-for-build-module-grain env (registered-build name :ensure-build t)))
(defmethod graph-for-build-module-grain :before (env (grain build-module-grain))
(finalize-grain grain))
(defmethod graph-for-build-module-grain ((env enforcing-traversal) (build build-module-grain))
(cond
((target-ecl-p)
(graph-for env `(:dynamic-library ,(fullname build))))
((and *target-can-dump-image-p*
(let ((post-image-name (build-image-name build)))
(and post-image-name
(graph-for env `(:image ,post-image-name))))))
(t
(make-phony-grain
:name `(:build ,(fullname build))
:dependencies
(progn
(build-command-for* env (load-dependencies build))
(traversed-dependencies env))))))
(define-graph-for :dynamic-library ((env enforcing-traversal) name)
(assert (target-ecl-p))
(second (graph-for-build-libraries env name)))
(define-graph-for :static-library ((env enforcing-traversal) name)
(assert (target-ecl-p))
(first (graph-for-build-libraries env name)))
(defmethod graph-for-build-libraries ((env static-traversal) name)
(check-type name string)
(assert (target-ecl-p))
(setf (linking-traversal-p env) t)
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
;; We want to compute the *difference* between the build-commands-for
;; the build dependencies of the library and build-commands-for the library and its dependencies.
;; i.e. what does the build include that's new?
;; then we package that into a nice static library (for linking) and dynamic library (for loading)
(let* ((build (registered-build name :ensure-build t))
(build-dependencies
(progn
(pre-image-for env build)
(build-dependencies build)))
(traversed
(progn
(build-command-for* env build-dependencies)
(setf (traversed-build-commands-r env) nil) ;; but keep issued-build-commands as it is!
(build-command-for* env (load-dependencies build))
(traversed-dependencies env)))
(image-setup (image-setup env))
(build-commands (traversed-build-commands env)) ;; only the new ones!
(issued-build-commands (issued-build-commands env)) ;; including the old ones!
(included-dependencies (included-dependencies env))) ;; including the old ones!
(flet ((make-library (class keyword)
(make-grain
class :fullname `(,keyword ,name)
:load-dependencies build-dependencies
:issued-build-commands issued-build-commands
:included-dependencies included-dependencies)))
(let* ((static-library-grain
(make-library 'static-library-grain :static-library))
(dynamic-library-grain
(make-library 'dynamic-library-grain :dynamic-library))
(grains (list static-library-grain dynamic-library-grain)))
(make-computation env
:outputs grains
:inputs traversed
:command
`(:xcvb-driver-command
,image-setup
(:create-bundle
(:bundle (:static-library ,name) :kind :static-library)
,@build-commands)
(:create-bundle
(:bundle (:dynamic-library ,name) :kind :shared-library)
,@build-commands)))
grains))))
(define-graph-for :image ((env static-traversal) name)
Francois-Rene Rideau
committed
((null name) ; special: no image
nil)
((equal name "/_") ;; special: initial image
(graph-for-image-grain env name nil nil))
((string-prefix-p "/_pre/" name)
(let* ((build-name (subseq name 5))
Francois-Rene Rideau
committed
(build (registered-build build-name :ensure-build t)))
(finalize-grain build)
(let* ((dependencies (build-dependencies build))
(starting-build-name (build-starting-dependencies-p dependencies))
(starting-build-image-name
(when starting-build-name
Francois-Rene Rideau
committed
(build-post-image-name
(registered-build starting-build-name :ensure-build t)))))
(graph-for-image-grain env name (or starting-build-image-name "/_") dependencies))))
Francois-Rene Rideau
committed
(let* ((build (registered-build name :ensure-build t)))
(graph-for-image-grain
env name (build-pre-image-name build) (load-dependencies build))))))
(define-graph-for :executable ((env static-traversal) name)
(registered-grain `(:executable ,name)))
(defun pre-image-for (env grain)
Francois-Rene Rideau
committed
(issue-image-named env (build-pre-image-name grain)))
Francois-Rene Rideau
committed
(defun issue-image-named (env name)
(if name
(let ((image (graph-for env `(:image ,name))))
(issue-dependency env image)
(include-image-dependencies env image)
(setf (image-setup env) `(:image ,(fullname image)))
(progn
;; TODO: issue dependency for
;; lisp executable/wrapper (in $PATH),
;; actual executable/driver (self/exe),
;; base image/core
;; if one is not found (or even if it is?),
;; use lisp-implementation-version and *features* as a proxy.
(when (linking-traversal-p env)
(assert (null (traversed-build-commands-r env)))
(loop :for dep :in *lisp-setup-dependencies* :do
(build-command-for env dep)))
(setf (image-setup env)
`(:load ,(loop
:for dep :in *lisp-setup-dependencies*
:for grain = (graph-for env dep)
:do (issue-dependency env grain)
:collect (fullname grain))))
nil)))
(defun make-load-file-command (fullname)
`(:load-file ,fullname))
(defun unwrap-load-file-command (x)
(second x)))
(defun remove-load-file (x)
(or (unwrap-load-file-command x)
(error "cannot remove :load-file from ~S" x)))
(defun require-command-p (x)
(and (list-of-length-p 2 x) (eq (first x) :require)))
Francois-Rene Rideau
committed
;;; TODO: have an actual grain for the manifest!
;;; TODO: have a better language for describing computations!
(defun manifest-and-build-commands (name image-setup build-commands)
(cond
((and *use-master* (target-ecl-p))
(values
`((:make-manifest
(:manifest ,name)
,@build-commands))
`((:load-manifest (:manifest ,name)))))
(*use-master*
(let ((initial-loads (getf image-setup :load))
(initial-name (strcat name "__initial")))
(values
(append
(when initial-loads
`((:make-manifest
(:manifest ,initial-name)
,@(mapcar 'make-load-file-command initial-loads))))
(when build-commands
`((:make-manifest
(:manifest ,name)
,@build-commands))))
(append
(when initial-loads
`((:initialize-manifest (:manifest ,initial-name))))
(when build-commands
`((:load-manifest (:manifest ,name))))))))
(t
(values nil build-commands))))
(defmethod graph-for-image-grain ((env static-traversal) name pre-image-name dependencies
&key executable pre-image-dump post-image-restart entry-point)
(declare (optimize (debug 3) (safety 3)))
(setf (linking-traversal-p env) (target-ecl-p))
Francois-Rene Rideau
committed
(let ((pre-image (issue-image-named env pre-image-name)))
(build-command-for* env dependencies)
Francois-Rene Rideau
committed
(let* ((traversed (traversed-dependencies env))
(build-commands-r (traversed-build-commands-r env))
(build-commands (reverse build-commands-r))
(manifest-and-build-commands
(multiple-value-list
(manifest-and-build-commands name image-setup build-commands)))
(manifest-maker (first manifest-and-build-commands))
(build-commands-spec (second manifest-and-build-commands))
(world (make-instance
'world-grain
:fullname (make-world-name image-setup build-commands-r)
:issued-build-commands
(make-hashset :test 'equal :list build-commands-r)
:included-dependencies
(make-hashset :test 'equal
:set (when pre-image (included-dependencies pre-image))
:list traversed)))
(if executable
(registered-grain `(:executable ,name))
(make-grain 'image-grain
:fullname `(:image ,name)
:world world)))
(fullname (fullname grain)))
:outputs (list grain)
:inputs traversed
:command
`(:progn
,@manifest-maker
(:xcvb-driver-command
,image-setup
(:create-image
(:image ,fullname
,@(when executable
`(:executable t :pre-image-dump ,pre-image-dump
:post-image-restart ,post-image-restart
:entry-point ,entry-point)))
,@build-commands-spec))))
(define-graph-for :source (env name &key in)
(declare (ignore env))
(make-source-grain :name name :in in))
(defun make-source-grain (&key name in)
(make-instance
'source-grain
:computation nil
:name name
:in in
:fullname `(:source ,name :in ,in)))
(define-graph-for :fasl ((env enforcing-traversal) lisp-name)
(first (graph-for-fasls env lisp-name)))
(define-graph-for :cfasl ((env enforcing-traversal) lisp-name)
(assert *use-cfasls*)
(second (graph-for-fasls env lisp-name)))
(define-graph-for :lisp-object ((env enforcing-traversal) lisp-name)
(assert (target-ecl-p))
(second (graph-for-fasls env lisp-name)))
(defun setup-dependencies-before-fasl (fullname)
(assert (equal '(:fasl "/xcvb/driver") (car *lisp-setup-dependencies*)))
(reverse ; put back in order
(cdr ; skip the current dependency itself
(member `(:fasl ,(second fullname)) ; what is up to the current dependency
(reverse *lisp-setup-dependencies*)
:test #'equal))))
(define-graph-for :asdf ((env static-traversal) system-name)
(declare (ignorable env))
(let* ((phony (make-instance 'phony-grain
:fullname `(:build-asdf ,system-name))))
(issue-image-named env nil)
(build-command-for env '(:build "/asdf"))
(make-computation
env :outputs (list phony) :inputs (traversed-dependencies env) :command
`(:xcvb-driver-command ,(image-setup env) (:initialize-asdf) (:load-asdf ,system-name)))
(call-next-method)))
(defmethod make-computation ((env static-traversal) &rest keys &key &allow-other-keys)
(apply #'make-computation () keys))
(defmethod graph-for-fasls ((env static-traversal) fullname)
(let* ((lisp (graph-for env fullname))
Francois-Rene Rideau
committed
(fullname (fullname lisp)) ;; canonicalize the fullname
(driverp (equal fullname '(:lisp "/xcvb/driver")))
(specialp (member `(:fasl ,(second fullname)) *lisp-setup-dependencies* :test #'equal)))
(check-type lisp lisp-file-grain)
(finalize-grain lisp)
(let ((build-dependencies (if specialp
(setup-dependencies-before-fasl fullname)
(build-dependencies lisp)))
(compile-dependencies (compile-dependencies lisp))
(cload-dependencies (cload-dependencies lisp))
(load-dependencies (load-dependencies lisp))
(around-compile (effective-around-compile lisp))
(encoding (effective-encoding lisp)))
(issue-dependency env lisp)
(unless specialp
(pre-image-for env lisp))
(build-command-for* env build-dependencies)
(build-command-for* env compile-dependencies)
(let* ((outputs (fasl-grains-for-name
env fullname
load-dependencies cload-dependencies
build-dependencies))
(cfasl (when *use-cfasls* (fullname (second outputs))))
(lisp-object (when (target-ecl-p) (fullname (second outputs)))))
(make-computation
env
:outputs outputs
Francois-Rene Rideau
committed
:inputs (traversed-dependencies env)
(if driverp
`(:compile-file-directly ,fullname :cfasl ,cfasl :lisp-object ,lisp-object)
`(:xcvb-driver-command
,(if specialp `(:load '(:fasl "/xcvb/driver"))
(:compile-lisp
(,fullname
Francois-Rene Rideau
committed
,@(when around-compile `(:around-compile ,around-compile))
,@(when encoding `(:encoding ,encoding)))
,@(traversed-build-commands env)))))
outputs))))