devops: Specify target Scheme arch; support cross-compiling to svm.

When a host's target arch is svm, do NOT build Debian packages.

diff --git a/src/devops/build.scm b/src/devops/build.scm
index 071fa8dc2a6fa6fba2ab47ae1215e440a45a242b..88af40e2625e075e1556cf507df95564bedca68d 100644 (file)
--- a/src/devops/build.scm
+++ b/src/devops/build.scm
@@ -99,11 +99,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                (rename-file elogfile logfile))))))
 
 (define (build-core-pkg name vers)
-  (let ((sarch build-scheme-architecture)
-       (pkgdir (string build-dir"/"name"-"vers)))
+  (let* ((sarch build-scheme-architecture)
+        (target (if (string-prefix? "svm" sarch) "svm" sarch))
+        (pkgdir (string build-dir"/"name"-"vers))
+        (host (shell-output
+               "echo \"(display microcode-id/compiled-code-type)\""
+               " | ${MIT_SCHEME_EXE=mit-scheme} --batch-mode"))
+        (cross (if (string=? target host)
+                   ""
+                   " --enable-cross-compiling")))
     (run "rm -rf "pkgdir)
     (run "cd "build-dir" && tar xzf "name"-"vers".tar.gz")
-    (run "cd "pkgdir"/src && ./configure --enable-native-code="sarch)
+    (run "cd "pkgdir"/src && ./configure"cross" --enable-native-code="target)
     (run "cd "pkgdir"/src && make")
     (run "cd "pkgdir"/src/microcode && make distclean")
     (run "cd "pkgdir"/doc && ./configure")
@@ -113,7 +120,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (run "chmod 444 "pkgdir"-"sarch".tar.gz")
     (run "rm -rf "pkgdir)
     (run "cd "build-dir" && tar xzf "name"-"vers"-"sarch".tar.gz")
-    (run "cd "pkgdir"/src && ./configure")
+    (run "cd "pkgdir"/src && ./configure"cross" --enable-native-code="target)
     (run "cd "pkgdir"/src && make compile-microcode")
     (run "cd "pkgdir"/src && umask 022 && make install")
     (run "cd "pkgdir"/doc && ./configure")

diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index 33b33ed85c601fe4a589daa0068a4a577f1c7e50..271af182e96649ccf3b86fc138b31ab2d2b42944 100644 (file)
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -456,7 +456,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                 (if (string=? proj name)
                     (write-pkg-status name vers sarch files host i/o)))
 
-            (if (host-ubuntu? host)
+            (if (host-build-ubuntu? host)
                 (let ((dsc (string name"_"vers".dsc"))
                       (tar (string name"_"vers".tar.xz")))
                   (if (or (not (member dsc files))
@@ -523,9 +523,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                          (error "could not find build script")))))
              i/o)
 
-  ;;(verify-host-debian-architecture host i/o)
-  ;;(if (host-ubuntu? host)
-  ;;    (verify-host-ubuntu-ness host i/o))
+  (verify-host-architecture host i/o)
 
   (write-line `(begin
                 (set! project-name ,(project-name))
@@ -535,7 +533,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                 (set! build-debian-architecture
                       ,(host-debian-architecture host))
                 (set! build-ubuntu?
-                      ,(host-ubuntu? host))
+                      ,(host-build-ubuntu? host))
                 (build))
              i/o)
   (flush-output-port i/o)
@@ -545,20 +543,20 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (close-input-port i/o)
   (close-output-port i/o))
 
-(define (verify-host-debian-architecture host i/o)
-  (let ((darch (read-reply '(read-debian-architecture) i/o)))
-    (if (not (string? darch))
-       (error "no Debian architecture"))
-    (if (not (string=? darch (host-debian-architecture host)))
-       (error "wrong Debian architecture"))))
-
-(define (verify-host-ubuntu-ness host i/o)
-  (let ((str (read-reply '(if (ubuntu?) "yes" "no") i/o)))
-    (if (not (string? str))
-       (error "no Ubuntu-ness"))
-    (let ((ubu? (string=? "yes" str)))
-      (if (not (eq? ubu? (host-ubuntu? host)))
-         (error "wrong Ubuntu-ness")))))
+(define (verify-host-architecture host i/o)
+  (if (host-build-ubuntu? host)
+      (begin
+       (let ((darch (read-reply '(read-debian-architecture) i/o)))
+         (if (not (string? darch))
+             (error "no Debian architecture"))
+         (if (not (string=? darch (host-debian-architecture host)))
+             (error "wrong Debian architecture")))
+       (let ((str (read-reply '(if (ubuntu?) "yes" "no") i/o)))
+         (if (not (string? str))
+             (error "no Ubuntu-ness"))
+         (let ((ubu? (string=? "yes" str)))
+           (if (not (eq? ubu? (host-ubuntu? host)))
+               (error "wrong Ubuntu-ness")))))))
 
 (define (call-with-host-i/o host receiver)
   (call-with-current-continuation
@@ -675,22 +673,28 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
        n)))
 
 (define-record-type <host>
-    (make-host name user directory darch os)
+    (make-host name user directory arch os)
     host?
   (name host-name)
   (user host-user)
   (directory host-directory)
-  (darch host-debian-architecture)
+  (arch host-scheme-architecture)
   (os host-os))
 
 (define (host-ubuntu? host)
   (os-ubuntu? (host-os host)))
 
-(define (host-scheme-architecture host)
-  (let ((darch (host-debian-architecture host)))
-    (cond ((string=? "amd64" darch) "x86-64")
-         ((string=? "i386"  darch) "i386")
-         (else (error "unknown Debian architecture:" darch)))))
+(define (host-build-ubuntu? host)
+  (and (host-ubuntu? host)
+       (not (string-prefix? "svm" (host-scheme-architecture host)))))
+
+(define (host-debian-architecture host)
+  (let ((arch (host-scheme-architecture host)))
+    (cond ((string=? "x86-64" arch) "amd64")
+         ((string=? "i386" arch) "i386")
+         ((string=? "svm1-32" arch) #f)
+         ((string=? "svm1-64" arch) #f)
+         (else (error "unknown host architecture:" arch)))))
 
 (define (host-ubuntu-codename host)
   (ubuntu-os-codename (host-os host)))