From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp0 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id iLmWE2ztu149FwAA0tVLHw (envelope-from ) for ; Wed, 13 May 2020 12:51:56 +0000 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp0 with LMTPS id oO+fAnvtu14RJwAA1q6Kng (envelope-from ) for ; Wed, 13 May 2020 12:52:11 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id DB081940EED for ; Wed, 13 May 2020 12:52:07 +0000 (UTC) Received: from localhost ([::1]:40524 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jYqro-0001Jr-9U for larch@yhetil.org; Wed, 13 May 2020 08:52:08 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:40612) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1jYqri-0001Jj-Ci for bug-guix@gnu.org; Wed, 13 May 2020 08:52:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:46066) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1jYqri-0001H9-2Q for bug-guix@gnu.org; Wed, 13 May 2020 08:52:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jYqri-0007uv-0W for bug-guix@gnu.org; Wed, 13 May 2020 08:52:02 -0400 X-Loop: help-debbugs@gnu.org Subject: bug#41120: uvesafb service is unsupported on aarch64 Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Wed, 13 May 2020 12:52:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 41120 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: "pelzflorian \(Florian Pelz\)" Received: via spool by 41120-submit@debbugs.gnu.org id=B41120.158937427330359 (code B ref 41120); Wed, 13 May 2020 12:52:01 +0000 Received: (at 41120) by debbugs.gnu.org; 13 May 2020 12:51:13 +0000 Received: from localhost ([127.0.0.1]:57610 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jYqqu-0007ta-DD for submit@debbugs.gnu.org; Wed, 13 May 2020 08:51:12 -0400 Received: from eggs.gnu.org ([209.51.188.92]:37456) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jYqqo-0007t7-QL for 41120@debbugs.gnu.org; Wed, 13 May 2020 08:51:10 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:35491) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jYqqi-0000oY-Vo; Wed, 13 May 2020 08:51:01 -0400 Received: from [2a01:cb18:832e:5f00:7499:6e2e:99e3:10a4] (port=49622 helo=meru) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1jYqqi-0006AU-Ee; Wed, 13 May 2020 08:51:00 -0400 From: Mathieu Othacehe References: <20200507054015.GG2359@E5400> <87wo5ody1e.fsf@gmail.com> <20200507081234.GJ2359@E5400> <20200507145511.zfw5474uzecs2oum@pelzflorian.localdomain> <20200507145801.nmedsi44wtparffh@pelzflorian.localdomain> <875zd6lro0.fsf@gmail.com> Date: Wed, 13 May 2020 14:50:58 +0200 In-Reply-To: <875zd6lro0.fsf@gmail.com> (Mathieu Othacehe's message of "Fri, 08 May 2020 11:09:03 +0200") Message-ID: <87blms3snh.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.3 (gnu/linux) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-Spam-Score: -3.3 (---) X-BeenThere: bug-guix@gnu.org List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: 41120@debbugs.gnu.org Errors-To: bug-guix-bounces+larch=yhetil.org@gnu.org Sender: "bug-Guix" X-Scanner: scn0 X-Spam-Score: -1.01 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx1.migadu.com: domain of bug-guix-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=bug-guix-bounces@gnu.org X-Scan-Result: default: False [-1.01 / 13.00]; RCVD_VIA_SMTP_AUTH(0.00)[]; GENERIC_REPUTATION(0.00)[-0.53972486964697]; TO_DN_SOME(0.00)[]; R_SPF_ALLOW(-0.20)[+ip4:209.51.188.0/24:c]; IP_REPUTATION_HAM(0.00)[asn: 22989(0.06), country: US(-0.00), ip: 209.51.188.17(-0.54)]; DWL_DNSWL_FAIL(0.00)[209.51.188.17:server fail]; MX_GOOD(-0.50)[cached: eggs.gnu.org]; RCPT_COUNT_TWO(0.00)[2]; MAILLIST(-0.20)[mailman]; FORGED_RECIPIENTS_MAILLIST(0.00)[]; RCVD_IN_DNSWL_FAIL(0.00)[209.51.188.17:server fail]; R_DKIM_NA(0.00)[]; MIME_TRACE(0.00)[0:+,1:+,2:+,3:+]; ASN(0.00)[asn:22989, ipnet:209.51.188.0/24, country:US]; TAGGED_FROM(0.00)[larch=yhetil.org]; FROM_NEQ_ENVFROM(0.00)[othacehe@gnu.org,bug-guix-bounces@gnu.org]; ARC_NA(0.00)[]; MID_RHS_MATCH_FROM(0.00)[]; FROM_HAS_DN(0.00)[]; URIBL_BLOCKED(0.00)[gnu.org:email]; MIME_GOOD(-0.10)[multipart/mixed,text/plain,text/x-diff]; RCVD_TLS_LAST(0.00)[]; DMARC_NA(0.00)[gnu.org]; HAS_LIST_UNSUB(-0.01)[]; RWL_MAILSPIKE_POSSIBLE(0.00)[209.51.188.17:from]; RCVD_COUNT_SEVEN(0.00)[9]; FORGED_SENDER_MAILLIST(0.00)[] X-TUID: JqmATAg3Qa0W --=-=-= Content-Type: text/plain Hello, > We could maybe do something like that: > > (define (operating-system-hardware-specific-services) > #~(let-system (system target) > (cond > ((target-arm? system target) > '()) > ((target-intel? system target) > (list uvesafb-shepherd-service))))) > > (define (operating-system-kernel-specific-services) > #~(let-system (system target) > (cond > ((target-linux? system target) > linux-specific-services) > ((target-hurd? system target) > hurd-specific-services)))) > > This way, uvesafb-shepherd-service would be built and installed only > when producing a system targeting an Intel CPU. We could also extend > this mechanism to have kernel specific services. > > That would mean, we need to dig out Ludo patch introducing > let-system[1], but I think it was almost ready. Here's a rebased version of Ludo's patch. I'm not sure about the merge resolution in "lower-object", but otherwise it works fine! Ludo, would it be of to push it? Thanks, Mathieu --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-gexp-Compilers-can-now-return-lowerable-objects.patch >From dde0a1ca499a4ef0592d10158a00add16386bebb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 13 May 2020 14:34:17 +0200 Subject: [PATCH 1/2] gexp: Compilers can now return lowerable objects. * guix/gexp.scm (lower-object): Iterate if LOWERED is a struct. (lower+expand-object): New procedure. (gexp->sexp): Use it. (define-gexp-compiler): Adjust docstring. --- guix/gexp.scm | 71 ++++++++++++++++++++++++++++++++++----------------- 1 file changed, 48 insertions(+), 23 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index 2a4b36519c..a9a4b89ab4 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -226,32 +226,59 @@ procedure to expand it; otherwise return #f." corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. OBJ must be an object that has an associated gexp compiler, such as a ." - (match (lookup-compiler obj) - (#f - (raise (condition (&gexp-input-error (input obj))))) - (lower - ;; Cache in STORE the result of lowering OBJ. - (mlet %store-monad ((target (if (eq? target 'current) - (current-target-system) - (return target))) - (graft? (grafting?))) - (mcached (let ((lower (lookup-compiler obj))) - (lower obj system target)) - obj - system target graft?))))) + (let loop ((obj obj)) + (match (lookup-compiler obj) + (#f + (raise (condition (&gexp-input-error (input obj))))) + (lower + ;; Cache in STORE the result of lowering OBJ. + (mlet* %store-monad + ((target (if (eq? target 'current) + (current-target-system) + (return target))) + (graft? (grafting?)) + (lowered (mcached (let ((lower (lookup-compiler obj))) + (lower obj system target)) + obj + system target graft?))) + (if (and (struct? lowered) (not (eq? lowered obj))) + (loop lowered) + (return lowered))))))) + +(define* (lower+expand-object obj + #:optional (system (%current-system)) + #:key target (output "out")) + "Return as a value in %STORE-MONAD the output of object OBJ expands to for +SYSTEM and TARGET. Object such as , , or +expand to file names, but it's possible to expand to a plain data type." + (let loop ((obj obj) + (expand (and (struct? obj) (lookup-expander obj)))) + (match (lookup-compiler obj) + (#f + (raise (condition (&gexp-input-error (input obj))))) + (lower + (mlet %store-monad ((lowered (lower obj system target))) + ;; LOWER might return something that needs to be further lowered. + (if (struct? lowered) + ;; If we lack an expander, delegate to that of LOWERED. + (if (not expand) + (loop lowered (lookup-expander lowered)) + (return (expand obj lowered output))) + (return lowered))))))) ;lists, vectors, etc. (define-syntax define-gexp-compiler (syntax-rules (=> compiler expander) "Define NAME as a compiler for objects matching PREDICATE encountered in gexps. -In the simplest form of the macro, BODY must return a derivation for PARAM, an -object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is -#f except when cross-compiling.) +In the simplest form of the macro, BODY must return (1) a derivation for +a record of the specified type, for SYSTEM and TARGET (the latter of which is +#f except when cross-compiling), (2) another record that can itself be +compiled down to a derivation, or (3) an object of a primitive data type. The more elaborate form allows you to specify an expander: - (define-gexp-compiler something something? + (define-gexp-compiler something-compiler compiler => (lambda (param system target) ...) expander => (lambda (param drv output) ...)) @@ -1148,12 +1175,10 @@ and in the current monad setting (system type, etc.)" (or n? native?))) refs)) (($ (? struct? thing) output n?) - (let ((target (if (or n? native?) #f target)) - (expand (lookup-expander thing))) - (mlet %store-monad ((obj (lower-object thing system - #:target target))) - ;; OBJ must be either a derivation or a store file name. - (return (expand thing obj output))))) + (let ((target (if (or n? native?) #f target))) + (lower+expand-object thing system + #:target target + #:output output))) (($ (? self-quoting? x)) (return x)) (($ x) -- 2.26.2 --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0002-gexp-Add-let-system.patch >From 8fe7504a0935de7f0c8cba1236f3114d4e368093 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 13 May 2020 14:35:20 +0200 Subject: [PATCH 2/2] gexp: Add 'let-system'. * guix/gexp.scm (): New record type. (let-system): New macro. (system-binding-compiler): New procedure. (default-expander): Add catch-all case. * tests/gexp.scm ("let-system", "let-system, target") ("let-system, ungexp-native, target") ("let-system, nested"): New tests. * doc/guix.texi (G-Expressions): Document it. --- doc/guix.texi | 26 +++++++++++++++++++++++++ guix/gexp.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++- tests/gexp.scm | 50 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 126 insertions(+), 1 deletion(-) diff --git a/doc/guix.texi b/doc/guix.texi index d6fbd85fde..0281a4be45 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7811,6 +7811,32 @@ are also added to the load path of the gexp returned by Return @code{#t} if @var{obj} is a G-expression. @end deffn +@deffn {Scheme Syntax} let-system @var{system} +@deffnx {Scheme Syntax} let-system (@var{system} @var{target}) +Bind @var{system} to the currently targeted system---e.g., +@code{"x86_64-linux"}---within @var{body}. + +In the second case, additionally bind @var{target} to the current +cross-compilation target---a GNU triplet such as +@code{"arm-linux-gnueabihf"}---or @code{#f} if we are not +cross-compiling. + +@code{let-system} is useful in the occasional case where the object +spliced into the gexp depends on the target system, as in this example: + +@example +#~(system* + #+(let-system system + (cond ((string-prefix? "armhf-" system) + (file-append qemu "/bin/qemu-system-arm")) + ((string-prefix? "x86_64-" system) + (file-append qemu "/bin/qemu-system-x86_64")) + (else + (error "dunno!")))) + "-net" "user" #$image) +@end example +@end deffn + G-expressions are meant to be written to disk, either as code building some derivation, or as plain files in the store. The monadic procedures below allow you to do that (@pxref{The Store Monad}, for more diff --git a/guix/gexp.scm b/guix/gexp.scm index a9a4b89ab4..a70b723e57 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -112,6 +112,7 @@ gexp-compiler? file-like? lower-object + let-system lower-inputs @@ -195,7 +196,9 @@ returns its output file name of OBJ's OUTPUT." ((? derivation? drv) (derivation->output-path drv output)) ((? string? file) - file))) + file) + (obj ;lists, vectors, etc. + obj))) (define (register-compiler! compiler) "Register COMPILER as a gexp compiler." @@ -324,6 +327,52 @@ The expander specifies how an object is converted to its sexp representation." (derivation-file-name lowered) lowered))) + +;;; +;;; System dependencies. +;;; + +;; Binding form for the current system and cross-compilation target. +(define-record-type + (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 + compiler => (lambda (binding system target) + (match binding + (($ proc) + (with-monad %store-monad + ;; PROC is expected to return a lowerable object. + ;; 'lower-object' takes care of residualizing it to a + ;; derivation or similar. + (return (proc system target)))))) + + ;; Delegate to the expander of the object returned by PROC. + expander => #f) + ;;; ;;; File declarations. diff --git a/tests/gexp.scm b/tests/gexp.scm index 6a42d3eb57..c1d65b2c4e 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -322,6 +322,56 @@ (string-append (derivation->output-path drv) "/bin/touch")))))) +(test-equal "let-system" + (list `(begin ,(%current-system) #t) '(system-binding) '()) + (let ((exp #~(begin + #$(let-system system system) + #t))) + (list (gexp->sexp* exp) + (match (gexp-inputs exp) + (((($ (@@ (guix gexp) )) "out")) + '(system-binding)) + (x x)) + (gexp-native-inputs exp)))) + +(test-equal "let-system, target" + (list `(list ,(%current-system) #f) + `(list ,(%current-system) "aarch64-linux-gnu")) + (let ((exp #~(list #$@(let-system (system target) + (list system target))))) + (list (gexp->sexp* exp) + (gexp->sexp* exp "aarch64-linux-gnu")))) + +(test-equal "let-system, ungexp-native, target" + `(here it is: ,(%current-system) #f) + (let ((exp #~(here it is: #+@(let-system (system target) + (list system target))))) + (gexp->sexp* exp "aarch64-linux-gnu"))) + +(test-equal "let-system, nested" + (list `(system* ,(string-append "qemu-system-" (%current-system)) + "-m" "256") + '() + '(system-binding)) + (let ((exp #~(system* + #+(let-system (system target) + (file-append (@@ (gnu packages virtualization) + qemu) + "/bin/qemu-system-" + system)) + "-m" "256"))) + (list (match (gexp->sexp* exp) + (('system* command rest ...) + `(system* ,(and (string-prefix? (%store-prefix) command) + (basename command)) + ,@rest)) + (x x)) + (gexp-inputs exp) + (match (gexp-native-inputs exp) + (((($ (@@ (guix gexp) )) "out")) + '(system-binding)) + (x x))))) + (test-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) (ungexp coreutils) -- 2.26.2 --=-=-=--