unofficial mirror of guix-devel@gnu.org 
 help / color / mirror / code / Atom feed
* [PATCH] build: syscalls: Delay syscalls evaluation.
@ 2016-02-05 13:01 Manolis Ragkousis
  2016-02-06 17:36 ` Mark H Weaver
  0 siblings, 1 reply; 5+ messages in thread
From: Manolis Ragkousis @ 2016-02-05 13:01 UTC (permalink / raw)
  To: guix-devel; +Cc: Justus Winter

[-- Attachment #1: Type: text/plain, Size: 531 bytes --]

Hello hackers,

Justus tried to build Guix on his Hurd machine and he found out that
even though we disable (guix build syscalls) from building when
sys/mount.h is not present, it still tries to build it.

As I found out, (guix utils) module uses the syscalls module so that's
why it still tried to build it. That's why I followed a different approach.
I delayed the evaluation of ptr and proc on mount, umount, swapon, etc.
and it builds now.

WDYT? If you agree with the change I will push it to wip-hurd and/or
master.

Manolis

[-- Attachment #2: 0001-build-syscalls-Delay-syscalls-evaluation.patch --]
[-- Type: text/x-patch, Size: 6929 bytes --]

From 0e05ab007e312800d22949543e935d9b91093aee Mon Sep 17 00:00:00 2001
From: Manolis Ragkousis <manolis837@gmail.com>
Date: Fri, 5 Feb 2016 14:22:20 +0200
Subject: [PATCH] build: syscalls: Delay syscalls evaluation.

* guix/build/syscalls.scm (mount, umount, swapon,
  swapoff, clone, pivot-root): Delay syscalls evaluation.
---
 guix/build/syscalls.scm | 66 ++++++++++++++++++++++++++-----------------------
 1 file changed, 35 insertions(+), 31 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index ea68b22..60e6f50 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -22,6 +22,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-45)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
@@ -184,9 +185,11 @@
 (define MNT_EXPIRE      4)
 (define UMOUNT_NOFOLLOW 8)
 
+;; Delay syscalls evaluation so we can workaround the fact that they do not
+;; exist on GNU Hurd.
 (define mount
-  (let* ((ptr  (dynamic-func "mount" (dynamic-link)))
-         (proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
+  (let* ((ptr  (delay (dynamic-func "mount" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) `(* * * ,unsigned-long *)))))
     (lambda* (source target type #:optional (flags 0) options
                      #:key (update-mtab? #f))
       "Mount device SOURCE on TARGET as a file system TYPE.  Optionally, FLAGS
@@ -194,17 +197,18 @@ may be a bitwise-or of the MS_* <sys/mount.h> constants, and OPTIONS may be a
 string.  When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored.  When
 UPDATE-MTAB? is true, update /etc/mtab.  Raise a 'system-error' exception on
 error."
-      (let ((ret (proc (if source
-                           (string->pointer source)
-                           %null-pointer)
-                       (string->pointer target)
-                       (if type
-                           (string->pointer type)
-                           %null-pointer)
-                       flags
-                       (if options
-                           (string->pointer options)
-                           %null-pointer)))
+      (let ((ret ((force proc)
+                  (if source
+                      (string->pointer source)
+                      %null-pointer)
+                  (string->pointer target)
+                  (if type
+                      (string->pointer type)
+                      %null-pointer)
+                  flags
+                  (if options
+                      (string->pointer options)
+                      %null-pointer)))
             (err (errno)))
         (unless (zero? ret)
           (throw 'system-error "mount" "mount ~S on ~S: ~A"
@@ -214,13 +218,13 @@ error."
           (augment-mtab source target type options))))))
 
 (define umount
-  (let* ((ptr  (dynamic-func "umount2" (dynamic-link)))
-         (proc (pointer->procedure int ptr `(* ,int))))
+  (let* ((ptr  (delay (dynamic-func "umount2" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) `(* ,int)))))
     (lambda* (target #:optional (flags 0)
                      #:key (update-mtab? #f))
       "Unmount TARGET.  Optionally FLAGS may be one of the MNT_* or UMOUNT_*
 constants from <sys/mount.h>."
-      (let ((ret (proc (string->pointer target) flags))
+      (let ((ret ((force proc) (string->pointer target) flags))
             (err (errno)))
         (unless (zero? ret)
           (throw 'system-error "umount" "~S: ~A"
@@ -242,11 +246,11 @@ constants from <sys/mount.h>."
                  (loop (cons mount-point result))))))))))
 
 (define swapon
-  (let* ((ptr  (dynamic-func "swapon" (dynamic-link)))
-         (proc (pointer->procedure int ptr (list '* int))))
+  (let* ((ptr  (delay (dynamic-func "swapon" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) (list '* int)))))
     (lambda* (device #:optional (flags 0))
       "Use the block special device at DEVICE for swapping."
-      (let ((ret (proc (string->pointer device) flags))
+      (let ((ret ((force proc) (string->pointer device) flags))
             (err (errno)))
         (unless (zero? ret)
           (throw 'system-error "swapon" "~S: ~A"
@@ -254,11 +258,11 @@ constants from <sys/mount.h>."
                  (list err)))))))
 
 (define swapoff
-  (let* ((ptr  (dynamic-func "swapoff" (dynamic-link)))
-         (proc (pointer->procedure int ptr '(*))))
+  (let* ((ptr  (delay (dynamic-func "swapoff" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) '(*)))))
     (lambda (device)
       "Stop using block special device DEVICE for swapping."
-      (let ((ret (proc (string->pointer device)))
+      (let ((ret ((force proc) (string->pointer device)))
             (err (errno)))
         (unless (zero? ret)
           (throw 'system-error "swapoff" "~S: ~A"
@@ -326,16 +330,16 @@ string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
                                                '* '* '*
                                                '*)))
          ;; TODO: Don't do this.
-         (syscall-id (match (utsname:machine (uname))
-                       ("i686"   120)
-                       ("x86_64" 56)
-                       ("mips64" 5055)
-                       ("armv7l" 120))))
+         (syscall-id (delay (match (utsname:machine (uname))
+                              ("i686"   120)
+                              ("x86_64" 56)
+                              ("mips64" 5055)
+                              ("armv7l" 120)))))
     (lambda (flags)
       "Create a new child process by duplicating the current parent process.
 Unlike the fork system call, clone accepts FLAGS that specify which resources
 are shared between the parent and child processes."
-      (let ((ret (proc syscall-id flags
+      (let ((ret (proc (force syscall-id) flags
                        %null-pointer               ;child stack
                        %null-pointer %null-pointer ;ptid & ctid
                        %null-pointer))             ;unused
@@ -365,12 +369,12 @@ there is no such limitation."
                   (list err))))))))
 
 (define pivot-root
-  (let* ((ptr  (dynamic-func "pivot_root" (dynamic-link)))
-         (proc (pointer->procedure int ptr (list '* '*))))
+  (let* ((ptr  (delay (dynamic-func "pivot_root" (dynamic-link))))
+         (proc (delay (pointer->procedure int (force ptr) (list '* '*)))))
     (lambda (new-root put-old)
       "Change the root file system to NEW-ROOT and move the current root file
 system to PUT-OLD."
-      (let ((ret (proc (string->pointer new-root)
+      (let ((ret ((force proc) (string->pointer new-root)
                        (string->pointer put-old)))
             (err (errno)))
         (unless (zero? ret)
-- 
2.6.4


^ permalink raw reply related	[flat|nested] 5+ messages in thread
end of thread, other threads:[~2016-04-18 17:40 UTC | newest]

Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2016-02-05 13:01 [PATCH] build: syscalls: Delay syscalls evaluation Manolis Ragkousis
2016-02-06 17:36 ` Mark H Weaver
2016-02-07 20:47   ` Ludovic Courtès
2016-02-10 12:53   ` Manolis Ragkousis
2016-04-18 17:39     ` Ludovic Courtès

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).