From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Mon, 19 Feb 2018 02:02:42 +0000 (-0700)
Subject: devops: support Debugging Builds with a devops:make procedure.
X-Git-Tag: mit-scheme-pucked-devops-0.5~1
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4155ba12ebe6484bc962a6cb5748b297c445f3f1;p=mit-scheme.git

devops: support Debugging Builds with a devops:make procedure.
---

diff --git a/src/devops/build.texi b/src/devops/build.texi
index 655a92f4f..c2b200640 100644
--- a/src/devops/build.texi
+++ b/src/devops/build.texi
@@ -27,6 +27,7 @@ they were created.  No dependency checking is currently in place.
 @menu
 * Project Repository::
 * Project Configuration::
+* Debugging Builds::
 * Release Process::
 * Build Process::
 * Lint Detection::
@@ -92,6 +93,71 @@ the host's operating system.  If it starts with @code{"Ubuntu"} and
 mentions a recent Ubuntu version, the host will build Debian packages.
 @end deffn
 
+@node Debugging Builds
+@section Debugging Builds
+
+A debugging build runs in the working directory of a developer's git
+repository (or shadow thereof) and provides special options to core
+and plugin @code{./configure} scripts (e.g.
+@code{"--enable-debugging"}).  The build begins by loading a
+@file{devops-config.scm} file into the @code{(devops)} package where
+it can adjust many aspects of the build.  The special options for the
+build are specified by applying @code{make-configuration} to a list of
+strings.
+
+@deffn Procedure make-configuration . options
+@var{Options} should be a list of strings to be passed as arguments to
+the @code{./configure} scripts of the core and plugins.
+@end deffn
+
+An example @file{devops-config.scm} file:
+
+@smallexample
+;; Shared configuration.
+(load (merge-pathnames "devops/config.scm"
+                       (current-load-pathname)))
+;; Build-specific configuration.
+(make-configuration "--enable-debugging")
+@end smallexample
+
+If the working directory contains @file{src}, @file{doc} and
+@file{tests} subdirectories it is assumed to contain a core system.
+In this case a @code{--prefix} option is added to the core build
+configuration so that the core is installed in the subdirectories
+@file{bin}, @file{lib} and @file{share}.  The test core is built and
+installed first, and is used as the host Scheme for plugin builds and
+installs.  There is no inter-plugin dependency analysis currently, so
+plugins are built and installed serially in the order they were
+created.
+
+To accommodate multiple debugging builds, a ``shadow'' of the working
+directory can be created.  A shadow directory contains symbolic links
+to the files in a source directory and shadows of its subdirectories,
+much like the shadow directories created by the X11 build utility
+@code{lndir}.  If the build starts in a subdirectory of the working
+directory, it will assume the build is intended to run in shadows of
+the working directories.  If it does not find a
+@file{devops-config.scm} file in this subdirectory, it will attempt to
+load one from the working directory.
+
+@deffn Procedure devops:make target
+@var{Target} is optional and defaults to @code{native} which specifies
+a core with the same Scheme architecture as the host.  It can also be
+the symbol @code{svm} which specifies a core cross-compiled to a
+Scheme virtual machine with the same word size as the host.  Plugins,
+unlike the core, are always native to their host Scheme compiler
+@verb{|${MIT_SCHEME_EXE=mit-scheme}|} (as well as their C compiler
+@verb{|${CC=gcc}|}, dynamic linker, etc.).
+
+This procedure is continuable.  When restarted it first checks any
+shadow directories for missing or incorrect links, then re-makes and
+re-installs the core (if any) and each plugin in order.  Note that
+this does not take into account syntactic dependencies between
+plugins.  If a plugin exports syntax and changes how that syntax
+expands, any plugins using the syntax will need to be cleaned (at
+least partially) and re-built.
+@end deffn
+
 @node Release Process
 @section Release Process
 
diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index cd397bc36..b8737ad72 100644
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -30,6 +30,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (cond ((equal? arg1 "status") (apply devops:status (cdr cmdl)))
 	  ((equal? arg1 "release") (apply devops:release (cdr cmdl)))
 	  ((equal? arg1 "build") (apply devops:build (cdr cmdl)))
+	  ((equal? arg1 "make") (apply devops:make (cdr cmdl)))
 	  (else (error "Unknown developer operation:" cmdl)))))
 
 (define (devops:status #!optional name)
@@ -735,6 +736,250 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
        (deregister-timer-event record)
        value))))
 
+;;;; Make
+
+(define (devops:make target)
+  (if (not (member target '("native" "svm" "C" "C-old" "C2native" "C2svm")))
+      (error "unknown build target:" target))
+  (load-make-config)
+  (%exit
+   (call-with-current-continuation	;throw here to unwind all
+    (lambda (abort-job)
+      (bind-condition-handler (list condition-type:error)
+	  (named-lambda (job-error-handler condition)
+	    (fresh-line)
+	    (log "# "(emacs-friendly-timestamp)"\n")
+	    (write-condition-report condition (current-output-port))
+	    (newline)
+	    (flush-output)
+	    (abort-job 2))
+	(lambda ()
+	  (with-^G-interrupt-handler
+	   (named-lambda (job-^G-interrupt-handler)
+	     (abort-job 3))
+	   (lambda ()
+	     (devops:make* target)
+	     0))))))))
+
+(define (devops:make* target)
+  (let* ((prefix (or (get-environment-variable "PWD")
+		     (error "PWD not set")))
+	 (host-exe (or (get-environment-variable "MIT_SCHEME_EXE")
+		       "mit-scheme"))
+	 (target-exe 'unset))
+    (if (file-directory? ".git")
+	(make-install-doc prefix)
+	(if (file-directory? "../.git")
+	    (begin
+	      (lndir "../doc")
+	      (make-install-doc prefix)
+	      (for-each lndir '("../src" "../tests")))
+	    (error "not a git working directory:"
+		   (working-directory-pathname))))
+
+    ;;(set-environment-variable! "LD_LIBRARY_PATH" "/usr/local/lib")
+    (set-subprocess-environment-variable! "FAST" "please")
+    (delete-subprocess-environment-variable! "DISPLAY")
+
+    (log "# Host: "host-exe"\n")
+    (log "# Target: "target"\n")
+    (log "# Config: "make-config"\n")
+
+    (cond
+     ((equal? target "native")
+      (if (not (file-exists? "src/configure"))
+	  (trun "cd src/; ./Setup.sh"))
+      (if (not (file-exists? "src/Makefile"))
+	  (trun "cd src/; ./configure --prefix="prefix" "make-config))
+      (trun "cd src/; make tags")
+      (trun "cd src/; make all")
+      (trun "cd src/; make check")
+      (trun "cd src/; umask 022; make install")
+      (set! target-exe (project-name)))
+
+     ((equal? target "svm")
+      (if (not (file-exists? "src/configure"))
+	  (trun "cd src/; ./Setup.sh"))
+      (if (not (file-exists? "src/Makefile"))
+	  (trun "cd src/; ./configure" " --prefix="prefix
+		" --enable-cross-compiling --enable-native-code=svm "
+		make-config))
+      (trun "cd src/; make tags")
+      (trun "cd src/; make all")
+      (trun "cd src/; make check")
+      (trun "cd src/; umask 022; make install")
+      (set! target-exe (string (project-name)"-svm1")))
+
+     ((equal? target "C")
+      (if (not (file-exists? "src/configure"))
+	  (trun "cd src/; ./Setup.sh"))
+      (if (not (file-exists? "src/Makefile"))
+	  (trun "cd src/; ./configure --prefix="prefix
+		" --enable-native-code=C "make-config))
+      (trun "cd src/; make tags")
+      (trun "cd src/; make all-native")
+      (trun "cd src/; make check")
+      (trun "cd src/; umask 022; make install")
+      (set! target-exe (string (project-name)"-c")))
+
+     ((equal? target "C-old")
+      (trun "cd src/; make tags")
+      (trun "cd src/; ./etc/make-liarc-dist.sh --prefix="prefix" "make-config)
+      (trun "cd src/; ./etc/make-liarc.sh --prefix="prefix" "make-config)
+      (trun "cd src/; make check")
+      (trun "cd src/; umask 022; make install")
+      (set! target-exe (string (project-name)"-c")))
+
+     ((equal? target "C2native")
+      (trun "cd src/; make tags")
+      (trun "cd src/; ./etc/make-native.sh --prefix="prefix" "make-config)
+      (trun "cd src/; make check")
+      (trun "cd src/; umask 022; make install")
+      (set! target-exe (project-name)))
+
+     ((equal? target "C2svm")
+      (trun "cd src/; make tags")
+      (trun "cd src/; ./etc/make-native.sh --prefix="prefix" "make-config)
+      (trun "cd src/; make check")
+      (trun "cd src/; umask 022; make install")
+      (set! target-exe (string (project-name)"-svm1")))
+
+     (else
+      (error "Unexpected target:" target)))
+
+    (let ((plugin-errors
+	   (with-subprocess-environment-variable
+	    "MIT_SCHEME_EXE" (string prefix"/bin/"target-exe)
+	    (lambda ()
+	      (reduce + 0
+		      (map (lambda (plugin) (make-install-plugin plugin prefix))
+			   plugin-list))))))
+      (if (not (zero? plugin-errors))
+	  (error "plugins failed to build:" plugin-errors)))))
+
+(define (load-make-config)
+  (cond ((file-exists? "devops-config.scm")
+	 (load "devops-config.scm"))
+	((file-exists? "../devops-config.scm")
+	 (load "../devops-config.scm"))
+	((let* ((git-root (find-git-root))
+		(file (string git-root"/devops-config.scm")))
+	   (and (file-exists? file)
+		(begin (load file)
+		       #t))))
+	(else
+	 (error "no devops test configuration found"))))
+
+(define make-config "")
+(define (make-configuration . args)
+  (if (not (null? args))
+      (begin
+	(if (not (list-of-type? args string?))
+	    (error:wrong-type-argument args "list of strings"
+				       'make-configuration))
+	(set! make-config (decorated-string-append "" " " "" args))))
+  make-config)
+
+(define (lndir dest)
+  (let ((dirname (dirname dest)))
+    (let loop ((name (filename dest))
+	       (dstdir dirname)
+	       (srcdir "")
+	       (reldir (drop-slash dirname)))
+      (let ((dst (string dstdir name))
+	    (src (string srcdir name)))
+	(let ((dst-atts (file-attributes-direct dst))
+	      (src-atts (file-attributes-direct src)))
+	  (if (eq? #t (file-attributes/type dst-atts))
+	      (if (not (or (eq? #f src-atts)
+			   (eq? #t (file-attributes/type src-atts))))
+		  (warn "not a directory:" src)
+		  (let ((dstdir* (string dst"/"))
+			(srcdir* (string src "/"))
+			(reldir* (string "../"reldir"/"name)))
+		    (if (eq? #f src-atts)
+			(make-directory src))
+		    (for-each
+		      (lambda (name)
+			(cond ((string=? "." name))
+			      ((string=? ".." name))
+			      ((string-suffix? "~" name))
+			      (else (loop name dstdir* srcdir* reldir*))))
+		      (directory-file-names dst))))
+	      (let ((reldirname (string reldir"/"name)))
+		(if (eq? #f src-atts)
+		    (soft-link-file reldirname src)
+		    (let ((src-type (file-attributes/type src-atts)))
+		      (cond ((not (string? src-type))
+			     (warn "not a symlink:" src))
+			    ((not (string=? src-type reldirname))
+			     (warn "bogus symlink:" src reldirname))))))))))))
+
+(define (make-install-doc prefix)
+  (if (not (file-exists? "doc/configure"))
+      (trun "cd doc/; autoconf"))
+  (if (not (file-exists? "doc/Makefile"))
+      (trun "cd doc/; ./configure --prefix="prefix))
+  (trun "cd doc/; make all")
+  (trun "cd doc/; umask 022; make install"))
+
+(define (make-install-plugin plugin prefix)
+  (let ((result (ignore-errors
+		 (lambda () (make-install-plugin* plugin prefix)))))
+    (if (condition? result)
+	(begin
+	  (log "# "(plugin-name plugin)" failed to build:"
+	       " "(condition/report-string result)"\n")
+	  1)
+	0)))
+
+(define (make-install-plugin* plugin prefix)
+  (let ((dir (plugin-directory plugin)))
+    (if (not (file-directory? dir))
+	(error "plugin directory not found:" dir))
+    (log "# "dir":\n")
+    (if (not (file-exists? (string dir"/configure")))
+	(trun "cd "dir"/; ./autogen.sh"))
+    (if (not (file-exists? (string dir"/Makefile")))
+	(trun "cd "dir"/; ./configure --prefix="prefix))
+    (trun "cd "dir"/; make tags")
+    (trun "cd "dir"/; make all")
+    (trun "cd "dir"/; make check")
+    (trun "cd "dir"/; umask 022; make install")
+    (if (find (lambda (line) (string-prefix? "info_TEXINFOS" line))
+	      (file-lines dir"/Makefile.am"))
+	(begin
+	  (trun "cd "dir"/; umask 022; make install-html")
+	  (trun "cd "dir"/; umask 022; make install-pdf")))))
+
+(define (trun . strings)
+  ;;(log-timestamp)
+  (log "# "(emacs-friendly-timestamp)"\n")
+  (apply run strings))
+
+(define (emacs-friendly-timestamp)
+  (let ((dt (local-decoded-time)))
+    (define (pad num) (string-pad-left (number->string num) 2 #\0))
+    (let ((year (number->string (decoded-time/year dt)))
+	  (month (pad (decoded-time/month dt)))
+	  (day (pad (decoded-time/day dt)))
+	  (hour (pad (decoded-time/hour dt)))
+	  (minute (pad (decoded-time/minute dt)))
+	  (second (pad (decoded-time/second dt))))
+      (string year"-"month"-"day" "hour"."minute"."second))))
+
+(define (with-^G-interrupt-handler inside-handler thunk)
+  (let ((env (->environment '(runtime interrupt-handler)))
+	(outside-handler))
+    (dynamic-wind
+     (lambda ()
+       (set! outside-handler (environment-lookup env 'hook/^G-interrupt))
+       (environment-assign! env 'hook/^G-interrupt inside-handler))
+     thunk
+     (lambda ()
+       (set! inside-handler (environment-lookup env 'hook/^G-interrupt))
+       (environment-assign! env 'hook/^G-interrupt outside-handler)))))
+
 ;;;; Configuration
 
 (define (project-name #!optional name)
@@ -921,4 +1166,45 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	      (begin
 		(write-string line out)
 		(newline out)
-		(loop))))))))
\ No newline at end of file
+		(loop))))))))
+
+(define (find-git-root)
+  (let ((pwd (drop-slash (or (get-environment-variable "PWD")
+			     (error "PWD not set")))))
+    (let loop ((parent (drop-slash (dirname pwd))))
+      (if (string-null? parent)
+	  (error "no git root found:" pwd)
+	  (if (file-directory? (string parent"/.git"))
+	      parent
+	      (loop (drop-slash (dirname pwd))))))))
+
+(define (drop-slash string)
+  (let ((len-1 (fix:-1+ (string-length string))))
+    (if (and (fix:>= len-1 0)
+	     (char=? #\/ (string-ref string len-1)))
+	(string-slice string 0 len-1)
+	string)))
+
+(define (filename filename)
+  (let ((i (string-find-previous-char filename #\/)))
+    (if (not i)
+	filename
+	(string-slice filename (fix:1+ i)))))
+
+(define (dirname filename)
+  (let ((i (string-find-previous-char filename #\/)))
+    (if (not i)
+	""
+	(string-slice filename 0 (fix:1+ i)))))
+
+(define (basename filename)
+  (let* ((start (let ((i (string-find-previous-char filename #\/)))
+		  (if (not i)
+		      0
+		      (fix:1+ i))))
+	 (end (string-find-next-char filename #\. start)))
+    (if (not end)
+	(if (fix:zero? start)
+	    filename
+	    (string-slice filename start))
+	(string-slice filename start end))))
\ No newline at end of file