Re: bug#26339: closing bootloader serie.

[Ludovic Courtès]

Hi,

Mathieu Othacehe <address@hidden> skribis:

>> Does that make sense?
>
> Yes, it is now much clearer, thank you !
>
> My qemu virtualized ARM machine has been compiling for a week now
> (is it normal to have so few substitutes btw ?) and is not over yet.

It’s not normal to have so few substitutes.  ARM substitutes are always
lagging behind on our build farm, but hopefully we’ll get additional
ARM build machines soon.

> So, I'm really interested by the --target on guix system. Do you happend
> to have a draft of your experiments :) ?

Here’s a very crude patch that mixes a couple of experiments, i hope it
can be of any use to you.  :-)

For a start, I could polish the ‘let-system’ and ‘with-system’ patches,
if you want.

My idea was to eventually have a Shepherd service whose ‘start’ method
would be something like:

  (virtual-machine
    (with-system (target "arm-linux-gnueabihf")
      (operating-system
        …)))

IOW, a service that starts a GuixSD VM for another architecture.

Thoughts?

Ludo’.

Unstaged
modified   .dir-locals.el
@@ -72,6 +72,7 @@
    (eval . (put 'run-with-state 'scheme-indent-function 1))
    (eval . (put 'wrap-program 'scheme-indent-function 1))
    (eval . (put 'with-imported-modules 'scheme-indent-function 1))
+   (eval . (put 'let-system 'scheme-indent-function 1))
 
    (eval . (put 'call-with-container 'scheme-indent-function 1))
    (eval . (put 'container-excursion 'scheme-indent-function 1))
modified   gnu/services.scm
@@ -25,7 +25,8 @@
   #:use-module (guix profiles)
   #:use-module (guix sets)
   #:use-module (guix ui)
-  #:use-module ((guix utils) #:select (source-properties->location))
+  #:use-module ((guix utils) #:select (%current-target-system
+                                       source-properties->location))
   #:use-module (guix modules)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
@@ -265,6 +266,7 @@ This is a shorthand for (map (lambda (svc) ...) 
%base-services)."
 (define (system-derivation mentries mextensions)
   "Return as a monadic value the derivation of the 'system' directory
 containing the given entries."
+  (pk 'sysdrv (%current-target-system))
   (mlet %store-monad ((entries    mentries)
                       (extensions (sequence %store-monad mextensions)))
     (lower-object
modified   guix/gexp.scm
@@ -32,6 +32,7 @@
   #:export (gexp
             gexp?
             with-imported-modules
+            let-system
 
             gexp-input
             gexp-input?
@@ -167,7 +168,9 @@ returns its output file name of OBJ's OUTPUT."
     ((? derivation? drv)
      (derivation->output-path drv output))
     ((? string? file)
-     file)))
+     file)
+    (#f
+     thing)))
 
 (define (register-compiler! compiler)
   "Register COMPILER as a gexp compiler."
@@ -234,6 +237,51 @@ The expander specifies how an object is converted to its 
sexp representation."
     (return drv)))
 
 
+;;;
+;;; System dependencies.
+;;;
+
+;; Binding form for the current system and cross-compilation target.
+(define-record-type <system-binding>
+  (system-binding proc)
+  system-binding?
+  (proc system-binding-proc))
+
+(define-syntax let-system
+  (syntax-rules ()
+    "Introduce a system binding in a gexp.  The simplest form is:
+
+  (let-system system
+    (cond ((string=? system \"x86_64-linux\") ...)
+          (else ...)))
+
+which binds SYSTEM to the currently targeted system.  The second form is
+similar, but it also shows the cross-compilation target:
+
+  (let-system (system target)
+    ...)
+
+Here TARGET is bound to the cross-compilation triplet or #f."
+    ((_ (system target) exp0 exp ...)
+     (system-binding (lambda (system target)
+                       exp0 exp ...)))
+    ((_ system exp0 exp ...)
+     (system-binding (lambda (system target)
+                       exp0 exp ...)))))
+
+(define-gexp-compiler (system-binding-compiler (binding <system-binding>)
+                                               system target)
+  (match binding
+    (($ <system-binding> proc)
+     (let ((obj (proc system target)))
+       (match (and (struct? obj) (lookup-compiler obj))
+         (#f
+          (with-monad %store-monad
+            (return obj)))
+         (lower
+          (lower obj system #:target target)))))))
+
+
 ;;;
 ;;; File declarations.
 ;;;
@@ -485,14 +533,16 @@ corresponding input list as a monadic value.  When TARGET 
is true, use it as
 the cross-compilation target triplet."
   (with-monad %store-monad
     (sequence %store-monad
-              (map (match-lambda
-                     (((? struct? thing) sub-drv ...)
-                      (mlet %store-monad ((drv (lower-object
-                                                thing system #:target target)))
-                        (return `(,drv ,@sub-drv))))
-                     (input
-                      (return input)))
-                   inputs))))
+              (filter-map (match-lambda
+                            (((? struct? thing) sub-drv ...)
+                             (mlet %store-monad ((drv (lower-object
+                                                       thing system #:target 
target)))
+                               (if drv
+                                   (return `(,drv ,@sub-drv))
+                                   (return #f))))
+                            (input
+                             (return input)))
+                          inputs))))
 
 (define* (lower-reference-graphs graphs #:key system target)
   "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
@@ -817,6 +867,51 @@ environment."
                          (identifier-syntax modules)))
     body ...))
 
+;; (define-syntax alpha-rename
+;;   (syntax-rules (lambda begin)
+;;     ((_ (lambda (bindings ...) body ...) (env ...))
+;;      (lambda (y ...)
+;;        (alpha-rename (begin body ...)
+;;                      ((bindings ...) env ...))))
+;;     ((_ (begin exp ...) (env ...))
+;;      (begin (alpha-rename exp (env ...)) ...))
+;;     ((_ id (env ...))
+;;      (letrec-syntax ((lookup (syntax-rules (id)
+;;                                ((_ ((id alpha) _ (... ...)))
+;;                                 alpha)
+;;                                ((_ (_ rest (... ...)))
+;;                                 (lookup (rest (... ...))))
+;;                                ((_ ())
+;;                                 id))))
+;;        (lookup (env ...))))))
+
+(define-syntax alpha-rename
+  (lambda (s)
+    (syntax-case s (lambda begin)
+      ((_ (lambda (bindings ...) body ...) (env ...))
+       (with-syntax (((formals ...)
+                      (generate-temporaries #'(bindings ...))))
+         #'(lambda (formals ...)
+             (alpha-rename (begin body ...)
+                           (((bindings formals) ...) env ...)))))
+      ((_ (begin exp ...) (env ...))
+       #'(begin (alpha-rename exp (env ...)) ...))
+      ((_ (proc arg ...) (env ...))
+       #'((alpha-rename proc (env ...))
+          (alpha-rename arg (env ...))
+          ...))
+      ((_ id (env ...))
+       (identifier? (pk #'(env ...) #'id))
+       #'(letrec-syntax ((lookup (syntax-rules (id)
+                                   ((_ ((id alpha) _ (... ...)))
+                                    alpha)
+                                   ((_ (_ rest (... ...)))
+                                    (lookup (rest (... ...))))
+                                   ((_ ())
+                                    id))))
+           (lookup (env ...)))))))
+
+
 (define-syntax gexp
   (lambda (s)
     (define (collect-escapes exp)
modified   guix/profiles.scm
@@ -1211,7 +1211,8 @@ the entries in MANIFEST."
                              (hooks %default-profile-hooks)
                              (locales? #t)
                              (allow-collisions? #f)
-                             system target)
+                             system
+                             (target (%current-target-system)))
   "Return a derivation that builds a profile (aka. 'user environment') with
 the given MANIFEST.  The profile includes additional derivations returned by
 the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
modified   guix/scripts/system.scm
@@ -931,7 +931,8 @@ resulting from command-line parsing."
                              #:install-bootloader? bootloader?
                              #:target target #:device device
                              #:gc-root (assoc-ref opts 'gc-root)))))
-        #:system system))))
+        #:system system
+        #:target "arm-linux-gnueabihf"))))
 
 (define (process-command command args opts)
   "Process COMMAND, one of the 'guix system' sub-commands.  ARGS is its
@@ -1010,15 +1011,15 @@ argument list and OPTS is the option alist."
            (fail))))
       args))
 
-  (with-error-handling
-    (let* ((opts     (parse-command-line args %options
-                                         (list %default-options)
-                                         #:argument-handler
-                                         parse-sub-command))
-           (args     (option-arguments opts))
-           (command  (assoc-ref opts 'action)))
-      (parameterize ((%graft? (assoc-ref opts 'graft?)))
-        (process-command command args opts)))))
+  (let* ((opts     (parse-command-line args %options
+                                       (list %default-options)
+                                       #:argument-handler
+                                       parse-sub-command))
+         (args     (option-arguments opts))
+         (command  (assoc-ref opts 'action)))
+    (parameterize ((%graft? (assoc-ref opts 'graft?))
+                   (%current-target-system "arm-linux-gnueabihf"))
+      (process-command command args opts))))
 
 ;;; Local Variables:
 ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
modified   guix/store.scm
@@ -1136,18 +1136,24 @@ topological order."
   boolean)
 
 (define substitutable-paths
-  (operation (query-substitutable-paths (store-path-list paths))
-             "Return the subset of PATHS that is substitutable."
-             store-path-list))
+  (let ((proc (operation (query-substitutable-paths (store-path-list paths))
+                         "Return the subset of PATHS that is substitutable."
+                         store-path-list)))
+    (lambda (store lst)
+      (pk 's-p lst)
+      (proc store lst))))
 
 (define substitutable-path-info
-  (operation (query-substitutable-path-infos (store-path-list paths))
-             "Return information about the subset of PATHS that is
+  (let ((proc (operation (query-substitutable-path-infos (store-path-list 
paths))
+                         "Return information about the subset of PATHS that is
 substitutable.  For each substitutable path, a `substitutable?' object is
 returned; thus, the resulting list can be shorter than PATHS.  Furthermore,
 that there is no guarantee that the order of the resulting list matches the
 order of PATHS."
-             substitutable-path-list))
+                         substitutable-path-list)))
+    (lambda (store lst)
+      (pk 'subst-p-i lst)
+      (proc store lst))))
 
 (define built-in-builders
   (let ((builders (operation (built-in-builders)
@@ -1428,7 +1434,8 @@ where FILE is the entry's absolute file name and STAT is 
the result of
 (define* (run-with-store store mval
                          #:key
                          (guile-for-build (%guile-for-build))
-                         (system (%current-system)))
+                         (system (%current-system))
+                         target)
   "Run MVAL, a monadic value in the store monad, in STORE, an open store
 connection, and return the result."
   ;; Initialize the dynamic bindings here to avoid bad surprises.  The
@@ -1436,7 +1443,7 @@ connection, and return the result."
   ;; bind-time and not at call time, which can be disconcerting.
   (parameterize ((%guile-for-build guile-for-build)
                  (%current-system system)
-                 (%current-target-system #f))
+                 (%current-target-system target))
     (call-with-values (lambda ()
                         (run-with-state mval store))
       (lambda (result store)
modified   tests/gexp.scm
@@ -258,6 +258,23 @@
            (((thing "out"))
             (eq? thing file))))))
 
+(test-assert "let-system"
+  (list `(begin ,(%current-system) #t) '() '())
+  (let ((exp  #~(begin
+                  #$(let-system system system)
+                  #t)))
+    (list (gexp->sexp* exp)
+          (gexp-inputs exp)
+          (gexp-native-inputs exp))))
+
+(test-assert "let-system, target"
+  (list `(begin ,(%current-system) #t))
+  (let ((exp #~(list #$@(let-system (system target)
+                          (list system target)))))
+    (list (gexp->sexp* exp)
+          (gexp-inputs exp)
+          (gexp-native-inputs exp))))
+
 (test-assert "ungexp + ungexp-native"
   (let* ((exp    (gexp (list (ungexp-native %bootstrap-guile)
                              (ungexp coreutils)