unofficial mirror of bug-guile@gnu.org 
 help / color / mirror / Atom feed
From: ludo@gnu.org (Ludovic Courtès)
To: Jan Nieuwenhuizen <janneke@gnu.org>
Cc: 20272@debbugs.gnu.org
Subject: bug#20272: Support reproducible builds
Date: Wed, 21 Dec 2016 00:00:47 +0100	[thread overview]
Message-ID: <87eg12fbog.fsf@gnu.org> (raw)
In-Reply-To: <87mvfygjs1.fsf@gnu.org> ("Ludovic \=\?utf-8\?Q\?Court\=C3\=A8s\=22'\?\= \=\?utf-8\?Q\?s\?\= message of "Thu, 15 Dec 2016 00:42:22 +0100")

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

ludo@gnu.org (Ludovic Courtès) skribis:

> To demonstrate non-reproducibility (with the attached patch, which is a
> rebased version of Mark’s), just build the same module twice: once with
> its dependency evaluated, and then with its dependency compiled.  The
> results differ:

[...]

> In gnu.go.v2 the integers appended to generated symbols are lower
> because fewer symbols had to be generated.

This is fixed by introducing a “per-module gensym” (patch attached; to
be applied on top of the previous one).  That way, the sequence number
in generated identifiers only depends on the module being compiled, not
on whether other modules are being interpreted or not.

The ‘module-gensym’ procedure I added adds a hash of the module name in
the identifier, to distinguish from symbols introduced by ‘gensym’.
This makes symbols 3–4 characters longer; perhaps we could avoid it.

Thoughts?

Thanks,
Ludo’.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 19658 bytes --]

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 8ef7e5f..5d0e727 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -390,6 +390,7 @@ If there is no handler at all, Guile prints an error and then exits."
       (let ((i next-id))
         (set! next-id (+ i 1))
         i))))
+(define module-gensym gensym)
 (define (resolve-module . args)
   #f)
 
@@ -2731,6 +2732,20 @@ VALUE."
             (nested-define-module! (resolve-module '() #f) name mod)
             (accessor mod))))))
 
+(define* (module-gensym #:optional (id " mg") (m (current-module)))
+  "Return a fresh symbol in the context of module M, based on ID (a
+string or symbol).  As long as M is a valid module, this procedure is
+deterministic."
+  (define (->string number)
+    (number->string number 16))
+
+  (if m
+      (string->symbol
+       (string-append id "-"
+                      (->string (hash (module-name m) 10000)) "-"
+                      (->string (module-generate-unique-id! m))))
+      (gensym id)))
+
 (define (make-modules-in module name)
   (or (nested-ref-module module name)
       (let ((m (make-module 31)))
@@ -4322,7 +4337,6 @@ when none is available, reading FILE-NAME with READER."
                      syntax-locally-bound-identifiers
                      syntax-session-id)))
 
-
 \f
 
 ;;; Place the user in the guile-user module.
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index c81b69e..e46951d 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1483,7 +1483,8 @@
                                         s
                                         mod
                                         get-formals
-                                        (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                                        (map (lambda (tmp-c0a-a89 tmp-c0a-a88 tmp-c0a-a87)
+                                               (cons tmp-c0a-a87 (cons tmp-c0a-a88 tmp-c0a-a89)))
                                              e2*
                                              e1*
                                              args*)))
@@ -1515,7 +1516,7 @@
    (gen-var
      (lambda (id)
        (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
-         (gensym (string-append (symbol->string id) "-")))))
+         (module-gensym (symbol->string id)))))
    (lambda-var-list
      (lambda (vars)
        (let lvl ((vars vars) (ls '()) (w '(())))
@@ -1777,7 +1778,8 @@
             (apply (lambda (args e1 e2)
                      (build-it
                        '()
-                       (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                       (map (lambda (tmp-c0a-c54 tmp-c0a-c53 tmp-c0a-c52)
+                              (cons tmp-c0a-c52 (cons tmp-c0a-c53 tmp-c0a-c54)))
                             e2
                             e1
                             args)))
@@ -1789,7 +1791,8 @@
                 (apply (lambda (docstring args e1 e2)
                          (build-it
                            (list (cons 'documentation (syntax->datum docstring)))
-                           (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                           (map (lambda (tmp-c0a-c6a tmp-c0a-c69 tmp-c0a-c68)
+                                  (cons tmp-c0a-c68 (cons tmp-c0a-c69 tmp-c0a-c6a)))
                                 e2
                                 e1
                                 args)))
@@ -1812,7 +1815,8 @@
             (apply (lambda (args e1 e2)
                      (build-it
                        '()
-                       (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                       (map (lambda (tmp-c0a-c8a tmp-c0a-c89 tmp-c0a-c88)
+                              (cons tmp-c0a-c88 (cons tmp-c0a-c89 tmp-c0a-c8a)))
                             e2
                             e1
                             args)))
@@ -1824,7 +1828,8 @@
                 (apply (lambda (docstring args e1 e2)
                          (build-it
                            (list (cons 'documentation (syntax->datum docstring)))
-                           (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                           (map (lambda (tmp-c0a-ca0 tmp-c0a-c9f tmp-c0a-c9e)
+                                  (cons tmp-c0a-c9e (cons tmp-c0a-c9f tmp-c0a-ca0)))
                                 e2
                                 e1
                                 args)))
@@ -2340,7 +2345,7 @@
         (if (not (list? x))
           (syntax-violation 'generate-temporaries "invalid argument" x)))
       (let ((mod (cons 'hygiene (module-name (current-module)))))
-        (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls))))
+        (map (lambda (x) (wrap (module-gensym "t-") '((top)) mod)) ls))))
   (set! free-identifier=?
     (lambda (x y)
       (let ((x x))
@@ -2710,7 +2715,8 @@
                          #f
                          k
                          '()
-                         (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+                         (map (lambda (tmp-c0a-1 tmp-c0a tmp-c0a-10ff)
+                                (list (cons tmp-c0a-10ff tmp-c0a) tmp-c0a-1))
                               template
                               pattern
                               keyword)))
@@ -2726,7 +2732,8 @@
                              #f
                              k
                              (list docstring)
-                             (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+                             (map (lambda (tmp-c0a-111a tmp-c0a-1 tmp-c0a)
+                                    (list (cons tmp-c0a tmp-c0a-1) tmp-c0a-111a))
                                   template
                                   pattern
                                   keyword)))
@@ -2741,7 +2748,8 @@
                                  dots
                                  k
                                  '()
-                                 (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+                                 (map (lambda (tmp-c0a-2 tmp-c0a-1 tmp-c0a)
+                                        (list (cons tmp-c0a tmp-c0a-1) tmp-c0a-2))
                                       template
                                       pattern
                                       keyword)))
@@ -2757,7 +2765,8 @@
                                      dots
                                      k
                                      (list docstring)
-                                     (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+                                     (map (lambda (tmp-c0a-2 tmp-c0a-1 tmp-c0a)
+                                            (list (cons tmp-c0a tmp-c0a-1) tmp-c0a-2))
                                           template
                                           pattern
                                           keyword)))
@@ -2876,7 +2885,7 @@
                                              (apply (lambda (p)
                                                       (if (= lev 0)
                                                         (quasilist*
-                                                          (map (lambda (tmp) (list "value" tmp)) p)
+                                                          (map (lambda (tmp-c0a-11b7) (list "value" tmp-c0a-11b7)) p)
                                                           (quasi q lev))
                                                         (quasicons
                                                           (quasicons
@@ -2894,7 +2903,8 @@
                                                  (apply (lambda (p)
                                                           (if (= lev 0)
                                                             (quasiappend
-                                                              (map (lambda (tmp) (list "value" tmp)) p)
+                                                              (map (lambda (tmp-c0a-11bc) (list "value" tmp-c0a-11bc))
+                                                                   p)
                                                               (quasi q lev))
                                                             (quasicons
                                                               (quasicons
@@ -2927,7 +2937,9 @@
                               (if tmp
                                 (apply (lambda (p)
                                          (if (= lev 0)
-                                           (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev))
+                                           (quasilist*
+                                             (map (lambda (tmp-c0a-11d2) (list "value" tmp-c0a-11d2)) p)
+                                             (vquasi q lev))
                                            (quasicons
                                              (quasicons
                                                '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
@@ -2943,7 +2955,7 @@
                                     (apply (lambda (p)
                                              (if (= lev 0)
                                                (quasiappend
-                                                 (map (lambda (tmp) (list "value" tmp)) p)
+                                                 (map (lambda (tmp-c0a-11d7) (list "value" tmp-c0a-11d7)) p)
                                                  (vquasi q lev))
                                                (quasicons
                                                  (quasicons
@@ -3031,7 +3043,7 @@
                               (let ((tmp-1 ls))
                                 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                   (if tmp
-                                    (apply (lambda (t) (cons "vector" t)) tmp)
+                                    (apply (lambda (t--c0a) (cons "vector" t--c0a)) tmp)
                                     (syntax-violation
                                       #f
                                       "source expression failed to match any pattern"
@@ -3039,7 +3051,8 @@
                    (let ((tmp y))
                      (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
                        (if tmp-1
-                         (apply (lambda (y) (k (map (lambda (tmp) (list "quote" tmp)) y)))
+                         (apply (lambda (y)
+                                  (k (map (lambda (tmp-c0a-122c) (list "quote" tmp-c0a-122c)) y)))
                                 tmp-1)
                          (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
                            (if tmp-1
@@ -3048,7 +3061,8 @@
                                (if tmp-1
                                  (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
                                  (let ((else tmp))
-                                   (let ((tmp x)) (let ((t tmp)) (list "list->vector" t)))))))))))))))))
+                                   (let ((tmp x))
+                                     (let ((t--c0a-123b tmp)) (list "list->vector" t--c0a-123b)))))))))))))))))
        (emit (lambda (x)
                (let ((tmp x))
                  (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3061,7 +3075,8 @@
                                   (let ((tmp-1 (map emit x)))
                                     (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                       (if tmp
-                                        (apply (lambda (t) (cons '#(syntax-object list ((top)) (hygiene guile)) t))
+                                        (apply (lambda (t--c0a-124a)
+                                                 (cons '#(syntax-object list ((top)) (hygiene guile)) t--c0a-124a))
                                                tmp)
                                         (syntax-violation
                                           #f
@@ -3077,8 +3092,10 @@
                                           (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
                                             (let ((tmp ($sc-dispatch tmp-1 '(any any))))
                                               (if tmp
-                                                (apply (lambda (t-1 t)
-                                                         (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t))
+                                                (apply (lambda (t--c0a-125e t--c0a-125d)
+                                                         (list '#(syntax-object cons ((top)) (hygiene guile))
+                                                               t--c0a-125e
+                                                               t--c0a-125d))
                                                        tmp)
                                                 (syntax-violation
                                                   #f
@@ -3091,8 +3108,9 @@
                                           (let ((tmp-1 (map emit x)))
                                             (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                               (if tmp
-                                                (apply (lambda (t)
-                                                         (cons '#(syntax-object append ((top)) (hygiene guile)) t))
+                                                (apply (lambda (t--c0a-126a)
+                                                         (cons '#(syntax-object append ((top)) (hygiene guile))
+                                                               t--c0a-126a))
                                                        tmp)
                                                 (syntax-violation
                                                   #f
@@ -3105,8 +3123,9 @@
                                               (let ((tmp-1 (map emit x)))
                                                 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                                   (if tmp
-                                                    (apply (lambda (t)
-                                                             (cons '#(syntax-object vector ((top)) (hygiene guile)) t))
+                                                    (apply (lambda (t--c0a)
+                                                             (cons '#(syntax-object vector ((top)) (hygiene guile))
+                                                                   t--c0a))
                                                            tmp)
                                                     (syntax-violation
                                                       #f
@@ -3117,8 +3136,9 @@
                                        (if tmp-1
                                          (apply (lambda (x)
                                                   (let ((tmp (emit x)))
-                                                    (let ((t tmp))
-                                                      (list '#(syntax-object list->vector ((top)) (hygiene guile)) t))))
+                                                    (let ((t--c0a tmp))
+                                                      (list '#(syntax-object list->vector ((top)) (hygiene guile))
+                                                            t--c0a))))
                                                 tmp-1)
                                          (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
                                            (if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 7d12469..13e15be 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1,7 +1,7 @@
 ;;;; -*-scheme-*-
 ;;;;
 ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
-;;;;   2012, 2013 Free Software Foundation, Inc.
+;;;;   2012, 2013, 2016 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -460,9 +460,10 @@
               (make-letrec src in-order? ids vars val-exps body-exp)))))
 
 
-    ;; FIXME: use a faster gensym
     (define-syntax-rule (build-lexical-var src id)
-      (gensym (string-append (symbol->string id) "-")))
+      ;; Use a per-module counter instead of the global counter of
+      ;; 'gensym' so that the generated identifier is reproducible.
+      (module-gensym (symbol->string id)))
 
     (define-structure (syntax-object expression wrap module))
 
@@ -2598,7 +2599,9 @@
           (lambda (ls)
             (arg-check list? ls 'generate-temporaries)
             (let ((mod (cons 'hygiene (module-name (current-module)))))
-              (map (lambda (x) (wrap (gensym "t-") top-wrap mod)) ls))))
+              (map (lambda (x)
+                     (wrap (module-gensym "t-") top-wrap mod))
+                   ls))))
 
     (set! free-identifier=?
           (lambda (x y)
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index 60c87e3..23d37a8 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
 ;;; transformation of letrec into simpler forms
 
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2016 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -267,7 +267,9 @@
                     ;; bindings, in a `let' to indicate that order doesn't
                     ;; matter, and bind to their variables.
                     (list
-                     (let ((tmps (map (lambda (x) (gensym)) c)))
+                     (let ((tmps (map (lambda (x)
+                                        (module-gensym "fixlr"))
+                                      c)))
                        (make-let
                         #f (map cadr c) tmps (map caddr c)
                         (make-sequence
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 249961d..d280869 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM specific syntaxes and utilities
 
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc
+;; Copyright (C) 2001, 2009, 2016 Free Software Foundation, Inc
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -72,7 +72,7 @@
                            '()
                            (cons (car slots) (lp (cdr slots))))))
                (opts (list-tail slots (length reqs)))
-               (tail (gensym)))
+               (tail (module-gensym "defrec")))
           `(define (,(symbol-append 'make- stem) ,@reqs . ,tail)
              (let ,(map (lambda (o)
                           `(,(car o) (cond ((null? ,tail) ,(cadr o))
@@ -243,8 +243,8 @@
 ;; code looks good.
 
 (define-macro (transform-record type-and-common record . clauses)
-  (let ((r (gensym))
-        (rtd (gensym))
+  (let ((r (module-gensym "rec"))
+        (rtd (module-gensym "rtd"))
         (type-stem (trim-brackets (car type-and-common))))
     (define (make-stem s)
       (symbol-append type-stem '- s))

  reply	other threads:[~2016-12-20 23:00 UTC|newest]

Thread overview: 24+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2015-04-07 11:48 bug#20272: Support reproducible builds Ludovic Courtès
2016-02-04  2:41 ` Mark H Weaver
2016-02-04  9:35   ` Ludovic Courtès
2016-06-20 15:46   ` Andy Wingo
2016-02-11  7:09 ` Mark H Weaver
2016-02-12 16:29   ` Mark H Weaver
2016-06-20 15:48     ` Andy Wingo
2016-06-23 19:22       ` Andy Wingo
2016-11-03  6:54 ` Jan Nieuwenhuizen
2016-11-14 21:44   ` Jan Nieuwenhuizen
2016-12-14 16:25     ` Ludovic Courtès
2016-12-14 23:32       ` Ludovic Courtès
2016-12-14 23:42         ` Ludovic Courtès
2016-12-20 23:00           ` Ludovic Courtès [this message]
2016-12-21 23:53             ` Ludovic Courtès
2016-12-30 21:00               ` Ludovic Courtès
2017-03-07 19:55                 ` Ludovic Courtès
2017-02-28 13:26               ` Andy Wingo
2017-03-05 20:49                 ` Ludovic Courtès
2017-03-06 20:13                   ` Andy Wingo
2020-06-01 20:45 ` Andreas Rammhold
2020-06-02 12:25 ` Andreas Rammhold
     [not found] ` <87o8lcu1v8.fsf@gmail.com>
2020-11-24  4:44   ` Vagrant Cascadian
2023-11-17 20:28 ` Bernhard M. Wiedemann

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/guile/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=87eg12fbog.fsf@gnu.org \
    --to=ludo@gnu.org \
    --cc=20272@debbugs.gnu.org \
    --cc=janneke@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
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).