bug#27476: guix pull fails on powerful server

[Ludovic Courtès]

Hi!

Ricardo Wurmus <address@hidden> skribis:

> The following derivation will be built:
>    /gnu/store/z5bhk17nxmdhvj0g4cy038p25mzh1gys-guix-latest.drv
> copying and compiling to 
> '/gnu/store/s3s7xlqa10mvf8v0ypxz8gzw3lcf1x5z-guix-latest' with Guile 2.2.2...
> loading...       25.7% of 635 filesrandom seed for tests: 1506720257
> loading...       99.8% of 635 files
> compiling...     69.1% of 635 filesice-9/threads.scm:289:22: In procedure 
> loop:
> ice-9/threads.scm:289:22: Syntax error:
> guix/scripts/graph.scm:103:10: return: return used outside of 'with-monad' in 
> form (return (package-node-edges a))

The program below crashes with completely surreal backtraces in less
than a minute on my 4-thread laptop:

--8<---------------cut here---------------start------------->8---
(use-modules (ice-9 threads)
             (srfi srfi-1)
             (guix monads)
             (guix store))

(define threads
  (unfold (lambda (x) (> x 100))
          (lambda (x)
            (call-with-new-thread
             (lambda ()
               (define monad
                 (symbol-append 'foo-monad
                                (string->symbol (number->string x))))

               (while #t
                 (macroexpand
                  `(begin
                     (define-monad ,monad
                       (bind +)
                       (return -))
                     (with-monad ,monad
                       (return 3))
                     (mapm ,monad + '(1 2 3))))))))
          1+
          0))

(for-each join-thread threads)
--8<---------------cut here---------------end--------------->8---

Can you check if that also happens on your many-core machine?

The patch below seems to fix the problem: (guix monads) has shared state
(hash tables) used both at expansion-time and run-time, and it wasn’t
protected.

My hypothesis is that this was causing random memory corruption.  The
weird thing, though, is that the errors we were getting were not so
random.  Also, the load phase of ‘guix pull’ is sequential.

Could you test it and report back?

Thanks,
Ludo’.

diff --git a/guix/monads.scm b/guix/monads.scm
index 6ae616aca..c9c5da3bb 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -20,6 +20,7 @@
   #:use-module ((system syntax)
                 #:select (syntax-local-binding))
   #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
@@ -117,6 +118,7 @@
   ;; the syntax object of the parameter over which it is templated, and (2)
   ;; the syntax of its body.
   (define-once %templates (make-hash-table))
+  (define-once %template-lock (make-mutex))
 
   (define (register-template! name param body)
     (hash-set! %templates name (cons param body)))
@@ -139,8 +141,9 @@ template instances."
       (syntax-source s))
 
     (define current-info-port
-      ;; Port for debugging info.
-      (const (%make-void-port "w")))
+      ;; Port for debugging info.  Return a fresh port at each call to make
+      ;; sure we're thread-safe.
+      (lambda () (%make-void-port "w")))
 
     (define location-string
       (format #f "~a:~a:~a"
@@ -204,12 +207,14 @@ template instances."
        ;; Search for an instance of template NAME for this ACTUAL parameter.
        ;; On success, expand to the identifier of the instance; otherwise
        ;; expand to #f.
-       (any (matching-instance? #'name #'actual) %template-instances))
+       (with-mutex %template-lock
+         (any (matching-instance? #'name #'actual) %template-instances)))
       ((_ exists? name actual)
        ;; Likewise, but return a Boolean.
        (let ((result (->bool
-                      (any (matching-instance? #'name #'actual)
-                           %template-instances))))
+                      (with-mutex %template-lock
+                        (any (matching-instance? #'name #'actual)
+                             %template-instances)))))
          (unless result
            (format (current-warning-port)
                    "~a: warning: no specialization of template '~a' for '~a'~%"
@@ -220,8 +225,9 @@ template instances."
        ;; Expand to the definitions of all the existing templates
        ;; specialized for ACTUAL.
        #`(begin
-           #,@(hash-map->list (cut instance-definition <> <> #'actual)
-                              %templates))))))
+           #,@(with-mutex %template-lock
+                (hash-map->list (cut instance-definition <> <> #'actual)
+                                %templates)))))))
 
 (define-syntax define-template
   (lambda (s)