makefile-backend.lisp

#+xcvb
(module
  (:author ("Francois-Rene Rideau" "Stas Boukarev")
   :maintainer "Francois-Rene Rideau"
   ;; :run-depends-on ("string-escape")
   :depends-on ("profiling" "specials" "virtual-pathnames"
                "static-traversal" "computations" "extract-target-properties"
                "external-commands" "target-lisp-commands" "commands")))

(in-package :xcvb)

(declaim (optimize (debug 3) (safety 3) (speed 2) (compilation-speed 0)))

(defclass makefile-traversal ()
  ())

(defclass static-makefile-traversal (static-traversal makefile-traversal)
  ())

(defvar *makefile-target-directories-to-mkdir* ())
(defvar *makefile-target-directories* (make-hash-table :test 'equal))
(defvar *makefile-phonies* ())

(defmethod effective-namestring ((env makefile-traversal) fullname)
  (fullname-enough-namestring env fullname))
(defmethod pseudo-effective-namestring ((env makefile-traversal) fullname)
  (pseudo-fullname-enough-namestring env fullname))

(defun computations-to-Makefile (env)
  (with-output-to-string (s)
    (dolist (computation *computations*)
      (write-computation-to-makefile env s computation))))

(defun write-makefile (fullname &key output-path)
  "Write a Makefile to output-path with information about how to compile the specified BUILD."
  (multiple-value-bind (target-dependency build directory) (handle-target fullname)
    (declare (ignore build directory))
    (let* ((env (make-instance 'static-makefile-traversal))
           (default-output-path (subpathname *workspace* "xcvb.mk"))
           (actual-output-path
            (if output-path
                (merge-pathnames* output-path default-output-path)
                default-output-path))
           (makefile-path (ensure-absolute-pathname actual-output-path))
           (makefile-dir (pathname-directory-pathname makefile-path))
           (*default-pathname-defaults* makefile-dir)
           (*print-pretty* nil); otherwise SBCL will slow us down a lot.
           (*makefile-target-directories* (make-hash-table :test 'equal))
           (*makefile-target-directories-to-mkdir* nil)
           (*makefile-phonies* nil)
           (lisp-env-var (lisp-environment-variable-name :prefix nil))
           (*lisp-executable-pathname* ;; magic escape!
            (list :makefile "${" lisp-env-var "}")))
      (log-format 9 "output-path: ~S" output-path)
      (log-format 9 "default-output-path: ~S" default-output-path)
      (log-format 9 "actual-output-path: ~S" actual-output-path)
      (log-format 6 "makefile-path: ~S" makefile-path)
      (log-format 9 "*default-pathname-defaults*: ~S" *default-pathname-defaults*)
      (log-format 7 "workspace: ~S" *workspace*)
      (log-format 7 "cache: ~S" *cache*)
      (log-format 7 "object-cache: ~S" *object-cache*)
      ;; Pass 1: Traverse the graph of dependencies
      (log-format 8 "T=~A building dependency graph" (get-universal-time))
      (graph-for env target-dependency)
      ;; Pass 2: Build a Makefile out of the *computations*
      (log-format 8 "T=~A computing makefile body" (get-universal-time))
      (log-format 8 "All *computations*=~%~S" (reverse *computations*))
      (let ((body (computations-to-Makefile env)))
        (log-format 8 "T=~A creating makefile" (get-universal-time))
        (ensure-directories-exist makefile-path)
        (with-open-file (out makefile-path
                             :direction :output
                             :if-exists :supersede)
          (log-format 8 "T=~A printing makefile" (get-universal-time))
          (write-makefile-prelude
           :stream out :lisp-env-var lisp-env-var)
          (princ body out)
          (write-makefile-conclusion out)))
      (log-format 8 "T=~A done" (get-universal-time))
      ;; Return data for use by the non-enforcing Makefile backend.
      (values makefile-path makefile-dir))))

(defparameter +generated-file-warning-start+
  "### This file was automatically created by XCVB")

(defun write-generated-file-warning (stream implementation-pathname)
  (format stream "~
~A ~A with the arguments~%~
### ~{~A~^ ~}~%~
### It may have been specialized to the target implementation ~A~%~
### from ~A with the following features:~%~
###   ~S~%~%~
### DO NOT EDIT! Changes will be lost when XCVB overwrites this file.~%~%"
          +generated-file-warning-start+
          *xcvb-version* *arguments* *lisp-implementation-type*
          implementation-pathname *target-system-features*))

(defun write-makefile-prelude (&key stream lisp-env-var)
  (let ((vars (list lisp-env-var))
        (implementation-pathname
         (or *target-lisp-executable-pathname*
             (lisp-implementation-name (get-lisp-implementation)))))
    (write-generated-file-warning stream implementation-pathname)
    (format stream "X~A ?= ~A~%~2:*~A ?= ${X~:*~A}~%" lisp-env-var implementation-pathname)
    (case *lisp-implementation-type*
      ((:ccl :sbcl)
       (let ((dir-var (lisp-implementation-directory-variable (get-lisp-implementation))))
         (format stream "_o_ = ~A~%~A ?= $(shell $(_o_))~%"
                 (escape-string-hashes
                  (shell-tokens-to-Makefile
                   (lisp-invocation-arglist
                    :cross-compile nil
                    :eval (format nil "(progn (princ ~A)(terpri)~A)"
                                  (association '*lisp-implementation-directory*
                                               *target-properties-variables*)
                                  (quit-form)))))
                 dir-var)
         (append1f vars dir-var))))
    (format stream "export~{ ~A~}~%~%" vars))
  (format stream "
XCVB_EOD :=
ifneq ($(wildcard ~A),~:*~A)
  XCVB_EOD := xcvb-ensure-object-directories
endif~2%"
          (join-strings
           (mapcar #'escape-string-for-Makefile
                   (mapcar 'enough-namestring
                           *makefile-target-directories-to-mkdir*))
           :separator " ")))

;; TODO: clean
;; * a clean-xcvb target that removes the object directory
(defun write-makefile-conclusion (&optional stream)
  (format stream "
xcvb-ensure-object-directories:
	mkdir -p ~A

.PHONY: force xcvb-ensure-object-directories~{ ~A~}~2%"
          (shell-tokens-to-Makefile
           (mapcar 'enough-namestring *makefile-target-directories-to-mkdir*))
          *makefile-phonies*))

(defun ensure-makefile-will-make-pathname (env namestring)
  (declare (ignore env))
  (let* ((p (position #\/ namestring :from-end t :end nil))
         (dir (subseq namestring 0 p)))
    (unless (gethash dir *makefile-target-directories*)
      (setf (gethash dir *makefile-target-directories*) t)
      (unless (find-if (lambda (d) (portable-namestring-prefix<= dir d))
                       *makefile-target-directories-to-mkdir*)
        (setf *makefile-target-directories-to-mkdir*
              (cons dir
                    (remove-if (lambda (d) (portable-namestring-prefix<= d dir))
                               *makefile-target-directories-to-mkdir*))))))
  (values))

(defmethod vp-namestring :around ((env makefile-traversal) vp)
  (let ((namestring (call-next-method)))
    (when (eq (vp-root vp) :obj)
      (ensure-makefile-will-make-pathname env namestring))
    namestring))

(defmethod grain-pathname-text ((env makefile-traversal) (grain file-grain))
  (let ((pathname (call-next-method)))
    (values (escape-sh-token-for-Makefile (enough-namestring pathname)) pathname)))

(defmethod grain-pathname-text :around ((env makefile-traversal) grain)
  (declare (ignorable env grain))
  (or (call-next-method) ""))

(defun Makefile-commands-for-computation (env computation-command)
  (mapcar 'shell-tokens-to-Makefile
          (external-commands-for-computation env computation-command)))

(defun write-computation-to-makefile (env stream computation)
  (with-accessors ((command computation-command)
                   (inputs computation-inputs)
                   (outputs computation-outputs)) computation
    (let* ((first-output (first outputs))
           (dependencies (mapcar #'grain-computation-target inputs))
           (target (grain-pathname-text env first-output))
           (other-outputs (rest outputs)))
      (dolist (o other-outputs)
        (format stream "~&~A: ~A~%" (grain-pathname-text env o) target))
      (format stream "~&~A:~{~@[ ~A~]~}~@[~A~] ${XCVB_EOD}~%"
              target
              (mapcar/ #'grain-pathname-text env dependencies)
              (asdf-dependency-text env first-output dependencies))
      (when command
        (dolist (c (cons
                    (format nil "echo Building ~A" target)
                    (Makefile-commands-for-computation env command)))
          (format stream "~C@~A~%" #\Tab c)))
      (terpri stream))))

;;; This is only done for images, not for individual files.
;;; For finer granularity, we could possibly define for each ASDF system
;;; (and implementation) a variable
;;; ASDF_CL_PPCRE_UP_TO_DATE := $(shell ...)
;;; but that would require more work.
;;; Also, it doesn't make sense to try to beat ASDF at its own game:
;;; if you really want proper dependencies,
;;; you'll migrate from ASDF to XCVB anyway.
(defun asdf-dependency-text (env output inputs)
  (with-nesting ()
    (when (image-grain-p output))
    (let ((asdf-grains (remove-if-not #'asdf-grain-p inputs))))
    (when asdf-grains)
    (let* ((image-namestring (grain-namestring env output))
           (pathname-text (escape-sh-token-for-Makefile
                           (enough-namestring image-namestring)))))
    (with-output-to-string (s)
      (format s " $(shell [ -f ~A ] && " pathname-text)
      (shell-tokens-to-Makefile
       (lisp-invocation-arglist
        :image-path image-namestring
        :eval (format nil "(xcvb-driver::asdf-systems-up-to-date~{ ~S~})"
                      (mapcar #'asdf-grain-system-name asdf-grains)))
       s)
      (format s " || echo force)"))))

(defmethod grain-pathname-text ((env makefile-traversal) (grain phony-grain))
  (declare (ignore env))
  (let ((n (normalize-name-for-makefile (princ-to-string (fullname grain)))))
    (pushnew n *makefile-phonies* :test 'equal)
    n))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Make-Makefile ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-command make-makefile
    (("make-makefile" "mkmk" "mm")
     (&rest keys &key)
     `(,@+build-option-spec+
       ,@+setup-option-spec+
       ,@+base-image-option-spec+
       ,@+source-registry-option-spec+
       (("output-path" #\o) :type string :initial-value "xcvb.mk" :documentation "specify output path")
       ,@+xcvb-program-option-spec+
       ,@+workspace-option-spec+
       ,@+install-option-spec+
       ,@+lisp-implementation-option-spec+
       ,@+cfasl-option-spec+
       (("master" #\m) :type boolean :optional t :initial-value t :documentation "enable XCVB-master")
       ,@+verbosity-option-spec+
       ,@+profiling-option-spec+)
     "Create some Makefile"
     "Create Makefile rules to build a project." ignore)
  (apply 'make-build :makefile-only t keys))


(defun make-parallel-flag ()
  (if-bind (ncpus) (asdf::ncpus)
    (format nil "-l~A" (1+ ncpus))
    "-j"))

(defun invoke-make (&key target directory makefile parallel (on-error 'error) env)
  (let* ((make (or (getenv "MAKE") "make"))
         (make-command
          `(,@(when env `("env" ,@env))
            ,make
            ,@(when parallel (list (make-parallel-flag)))
            ,@(when directory `("-C" ,directory))
            ,@(when makefile `("-f" ,makefile))
            ,@(when target (ensure-list target)))))
      (log-format 6 "Building with ~S" make-command)
      (run ;; for side-effects
       :output :interactive
       make-command ; (strcat (escape-shell-command make-command) " >&2")
       :on-error on-error)))

(define-command make-build
    (("make-build" "mkb" "mb")
     (&rest keys &key makefile-only (retry t) (exit t))
     `(,@+make-makefile-option-spec+
       (("parallel" #\j) :type boolean :optional t :initial-value t :documentation "build in parallel"))
     "Use Make to build your project (in parallel)"
     "Create Makefile rules to build a project, use them."
     (build output-path parallel))
  (apply 'handle-global-options keys)
  (with-maybe-profiling ()
    (multiple-value-bind (makefile-path makefile-dir)
        (write-makefile build :output-path output-path)
      (if makefile-only
          (values makefile-path makefile-dir)
          (let ((code (nth-value 2 (invoke-make
                                    :directory makefile-dir :makefile makefile-path
                                    :parallel parallel))))
            (unless (zerop code)
              (when retry
                (invoke-make
                 :directory makefile-dir :makefile makefile-path :parallel parallel
                 :on-error nil :env '("XCVB_DEBUGGING=t"))))
            (if exit
                (exit code)
                (values code makefile-dir makefile-path)))))))