psyntax: Generate identifiers in a deterministic fashion.

Fixes <http://bugs.gnu.org/20272>.

* module/ice-9/boot-9.scm (module-generate-unique-id!)
(module-gensym): New procedures.
(module): Add 'next-unique-id' field.
(the-root-module): Inherit 'next-unique-id' value from early stub.
(make-module, make-autoload-interface): Adjust calls to
module-constructor.
* module/ice-9/psyntax.scm (gen-label, new-mark): Generate unique
identifiers from the module name and the per-module unique-id.
(build-lexical-var, generate-temporaries): Use
'module-gensym' instead of 'gensym'.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/language/tree-il/fix-letrec.scm (fix-letrec!): Use
'module-gensym' instead of 'gensym'.
* module/system/base/syntax.scm (define-record): Likewise.
(transform-record): Likewise.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>

3 files changed, 135 insertions, 44 deletions

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 75906ff4c..27776725b 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 1995-2014  Free Software Foundation, Inc.
+;;;; Copyright (C) 1995-2014, 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
@@ -373,6 +373,13 @@ If returning early, return the return value of F."
 (define (module-ref module sym)
   (let ((v (module-variable module sym)))
     (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
+(define module-generate-unique-id!
+  (let ((next-id 0))
+    (lambda (m)
+      (let ((i next-id))
+        (set! next-id (+ i 1))
+        i))))
+(define module-gensym gensym)
 (define (resolve-module . args)
   #f)
 
@@ -1982,7 +1989,8 @@ name extensions listed in %load-extensions."
      submodules
      submodule-binder
      public-interface
-     filename)))
+     filename
+     next-unique-id)))
 
 
 ;; make-module &opt size uses binder
@@ -2005,7 +2013,7 @@ initial uses list, or binding procedure."
                       (make-hash-table)
                       '()
                       (make-weak-key-hash-table 31) #f
-                      (make-hash-table 7) #f #f #f))
+                      (make-hash-table 7) #f #f #f 0))
 
 
 
@@ -2542,6 +2550,11 @@ interfaces are added to the inports list."
   (let ((m (make-module 0)))
     (set-module-obarray! m (%get-pre-modules-obarray))
     (set-module-name! m '(guile))
+
+    ;; Inherit next-unique-id from preliminary stub of
+    ;; %module-get-next-unique-id! defined above.
+    (set-module-next-unique-id! m (module-generate-unique-id! #f))
+
     m))
 
 ;; The root interface is a module that uses the same obarray as the
@@ -2570,6 +2583,11 @@ interfaces are added to the inports list."
       the-root-module
       (error "unexpected module to resolve during module boot" name)))
 
+(define (module-generate-unique-id! m)
+  (let ((i (module-next-unique-id m)))
+    (set-module-next-unique-id! m (+ i 1))
+    i))
+
 ;; Cheat.  These bindings are needed by modules.c, but we don't want
 ;; to move their real definition here because that would be unnatural.
 ;;
@@ -2600,6 +2618,21 @@ interfaces are added to the inports list."
             (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) most-positive-fixnum))
+                      "-"
+                      (->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)))
@@ -2891,7 +2924,7 @@ error if selected binding does not exist in the used module."
               #:warning "Failed to autoload ~a in ~a:\n" sym name))))
     (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
                         (make-hash-table 0) '() (make-weak-value-hash-table 31) #f
-                        (make-hash-table 0) #f #f #f)))
+                        (make-hash-table 0) #f #f #f 0)))
 
 (define (module-autoload! module . args)
   "Have @var{module} automatically load the module named @var{name} when one
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index d79766595..e410f9f58 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -295,9 +295,7 @@
            (syntax-object-expression x)
            (join-marks (car w) (car (syntax-object-wrap x))))
          (values x (car w)))))
-   (gen-label
-     (lambda ()
-       (string-append "l-" (session-id) (symbol->string (gensym "-")))))
+   (gen-label (lambda () (symbol->string (module-gensym "l"))))
    (gen-labels
      (lambda (ls)
        (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
@@ -994,14 +992,15 @@
                        (source-wrap e w (cdr w) mod)
                        x))
                     (else (decorate-source x s))))))
-         (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod))))
+         (let* ((t-680b775fb37a463-7fe transformer-environment)
+                (t-680b775fb37a463-7ff (lambda (k) (k e r w s rib mod))))
            (with-fluid*
-             t-1
-             t
+             t-680b775fb37a463-7fe
+             t-680b775fb37a463-7ff
              (lambda ()
                (rebuild-macro-output
                  (p (source-wrap e (anti-mark w) s mod))
-                 (gensym (string-append "m-" (session-id) "-")))))))))
+                 (module-gensym "m"))))))))
    (expand-body
      (lambda (body outer-form r w mod)
        (let* ((r (cons '("placeholder" placeholder) r))
@@ -1532,7 +1531,11 @@
                                         s
                                         mod
                                         get-formals
-                                        (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                                        (map (lambda (tmp-680b775fb37a463-aef
+                                                      tmp-680b775fb37a463-aee
+                                                      tmp-680b775fb37a463-aed)
+                                               (cons tmp-680b775fb37a463-aed
+                                                     (cons tmp-680b775fb37a463-aee tmp-680b775fb37a463-aef)))
                                              e2*
                                              e1*
                                              args*)))
@@ -1564,7 +1567,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 '(())))
@@ -1832,7 +1835,11 @@
             (apply (lambda (args e1 e2)
                      (build-it
                        '()
-                       (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                       (map (lambda (tmp-680b775fb37a463-cbc
+                                     tmp-680b775fb37a463-cbb
+                                     tmp-680b775fb37a463-cba)
+                              (cons tmp-680b775fb37a463-cba
+                                    (cons tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cbc)))
                             e2
                             e1
                             args)))
@@ -1844,7 +1851,11 @@
                 (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-680b775fb37a463-cd2
+                                         tmp-680b775fb37a463-cd1
+                                         tmp-680b775fb37a463-cd0)
+                                  (cons tmp-680b775fb37a463-cd0
+                                        (cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2)))
                                 e2
                                 e1
                                 args)))
@@ -1867,7 +1878,11 @@
             (apply (lambda (args e1 e2)
                      (build-it
                        '()
-                       (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                       (map (lambda (tmp-680b775fb37a463-cf2
+                                     tmp-680b775fb37a463-cf1
+                                     tmp-680b775fb37a463-cf0)
+                              (cons tmp-680b775fb37a463-cf0
+                                    (cons tmp-680b775fb37a463-cf1 tmp-680b775fb37a463-cf2)))
                             e2
                             e1
                             args)))
@@ -1879,7 +1894,11 @@
                 (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-680b775fb37a463-d08
+                                         tmp-680b775fb37a463-d07
+                                         tmp-680b775fb37a463-d06)
+                                  (cons tmp-680b775fb37a463-d06
+                                        (cons tmp-680b775fb37a463-d07 tmp-680b775fb37a463-d08)))
                                 e2
                                 e1
                                 args)))
@@ -2387,7 +2406,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))
@@ -2787,7 +2806,11 @@
                          #f
                          k
                          '()
-                         (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+                         (map (lambda (tmp-680b775fb37a463-115b
+                                       tmp-680b775fb37a463-115a
+                                       tmp-680b775fb37a463)
+                                (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-115a)
+                                      tmp-680b775fb37a463-115b))
                               template
                               pattern
                               keyword)))
@@ -2803,7 +2826,9 @@
                              #f
                              k
                              (list docstring)
-                             (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+                             (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                    (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+                                          tmp-680b775fb37a463-2))
                                   template
                                   pattern
                                   keyword)))
@@ -2818,7 +2843,11 @@
                                  dots
                                  k
                                  '()
-                                 (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+                                 (map (lambda (tmp-680b775fb37a463-118d
+                                               tmp-680b775fb37a463-118c
+                                               tmp-680b775fb37a463-118b)
+                                        (list (cons tmp-680b775fb37a463-118b tmp-680b775fb37a463-118c)
+                                              tmp-680b775fb37a463-118d))
                                       template
                                       pattern
                                       keyword)))
@@ -2834,7 +2863,11 @@
                                      dots
                                      k
                                      (list docstring)
-                                     (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+                                     (map (lambda (tmp-680b775fb37a463-11ac
+                                                   tmp-680b775fb37a463-11ab
+                                                   tmp-680b775fb37a463-11aa)
+                                            (list (cons tmp-680b775fb37a463-11aa tmp-680b775fb37a463-11ab)
+                                                  tmp-680b775fb37a463-11ac))
                                           template
                                           pattern
                                           keyword)))
@@ -2974,7 +3007,9 @@
                                              (apply (lambda (p)
                                                       (if (= lev 0)
                                                         (quasilist*
-                                                          (map (lambda (tmp) (list "value" tmp)) p)
+                                                          (map (lambda (tmp-680b775fb37a463)
+                                                                 (list "value" tmp-680b775fb37a463))
+                                                               p)
                                                           (quasi q lev))
                                                         (quasicons
                                                           (quasicons
@@ -2992,7 +3027,9 @@
                                                  (apply (lambda (p)
                                                           (if (= lev 0)
                                                             (quasiappend
-                                                              (map (lambda (tmp) (list "value" tmp)) p)
+                                                              (map (lambda (tmp-680b775fb37a463)
+                                                                     (list "value" tmp-680b775fb37a463))
+                                                                   p)
                                                               (quasi q lev))
                                                             (quasicons
                                                               (quasicons
@@ -3025,7 +3062,11 @@
                               (if tmp
                                 (apply (lambda (p)
                                          (if (= lev 0)
-                                           (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev))
+                                           (quasilist*
+                                             (map (lambda (tmp-680b775fb37a463-122f)
+                                                    (list "value" tmp-680b775fb37a463-122f))
+                                                  p)
+                                             (vquasi q lev))
                                            (quasicons
                                              (quasicons
                                                '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
@@ -3041,7 +3082,8 @@
                                     (apply (lambda (p)
                                              (if (= lev 0)
                                                (quasiappend
-                                                 (map (lambda (tmp) (list "value" tmp)) p)
+                                                 (map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
+                                                      p)
                                                  (vquasi q lev))
                                                (quasicons
                                                  (quasicons
@@ -3129,7 +3171,9 @@
                               (let ((tmp-1 ls))
                                 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
                                   (if tmp
-                                    (apply (lambda (t) (cons "vector" t)) tmp)
+                                    (apply (lambda (t-680b775fb37a463-127d)
+                                             (cons "vector" t-680b775fb37a463-127d))
+                                           tmp)
                                     (syntax-violation
                                       #f
                                       "source expression failed to match any pattern"
@@ -3137,7 +3181,9 @@
                    (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-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
+                                          y)))
                                 tmp-1)
                          (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
                            (if tmp-1
@@ -3146,7 +3192,9 @@
                                (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-680b775fb37a463 tmp))
+                                       (list "list->vector" t-680b775fb37a463)))))))))))))))))
        (emit (lambda (x)
                (let ((tmp x))
                  (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3159,7 +3207,9 @@
                                   (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-680b775fb37a463-12a7)
+                                                 (cons '#(syntax-object list ((top)) (hygiene guile))
+                                                       t-680b775fb37a463-12a7))
                                                tmp)
                                         (syntax-violation
                                           #f
@@ -3175,8 +3225,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-680b775fb37a463-12bb t-680b775fb37a463-12ba)
+                                                         (list '#(syntax-object cons ((top)) (hygiene guile))
+                                                               t-680b775fb37a463-12bb
+                                                               t-680b775fb37a463-12ba))
                                                        tmp)
                                                 (syntax-violation
                                                   #f
@@ -3189,8 +3241,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-680b775fb37a463-12c7)
+                                                         (cons '#(syntax-object append ((top)) (hygiene guile))
+                                                               t-680b775fb37a463-12c7))
                                                        tmp)
                                                 (syntax-violation
                                                   #f
@@ -3203,8 +3256,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-680b775fb37a463-12d3)
+                                                             (cons '#(syntax-object vector ((top)) (hygiene guile))
+                                                                   t-680b775fb37a463-12d3))
                                                            tmp)
                                                     (syntax-violation
                                                       #f
@@ -3215,8 +3269,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-680b775fb37a463-12df tmp))
+                                                      (list '#(syntax-object list->vector ((top)) (hygiene guile))
+                                                            t-680b775fb37a463-12df))))
                                                 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 88df4c753..74a008eeb 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, 2015 Free Software Foundation, Inc.
+;;;;   2012, 2013, 2015, 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
@@ -461,9 +461,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))
 
@@ -632,7 +633,7 @@
     ;; labels must be comparable with "eq?", have read-write invariance,
     ;; and distinct from symbols.
     (define (gen-label)
-      (string-append "l-" (session-id) (symbol->string (gensym "-"))))
+      (symbol->string (module-gensym "l")))
 
     (define gen-labels
       (lambda (ls)
@@ -661,7 +662,7 @@
                    (cons 'shift (wrap-subst w)))))
 
     (define-syntax-rule (new-mark)
-      (gensym (string-append "m-" (session-id) "-")))
+      (module-gensym "m"))
 
     ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
     ;; internal definitions, in which the ribcages are built incrementally
@@ -2717,7 +2718,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)