[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#20272: Support reproducible builds
|
From: |
Ludovic Courtès |
|
Subject: |
bug#20272: Support reproducible builds |
|
Date: |
Wed, 21 Dec 2016 00:00:47 +0100 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/25.1 (gnu/linux) |
address@hidden (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’.
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)))
-
;;; 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))