add current-generate-id

original commit: be555fa7605f17f8613b1c02fe9f5e187a7cfeb9

LOG

@@ -774,3 +774,6 @@
     5_3.ss, 5_3.ms, fl.ms, root-experr*, patch*
 - fix bug in date->time-utc caused by incorrect use of difftime in Windows
     stats.c, date.ms, release_notes.stex
+- add current-generate-id, which can be useful for avoiding library
+  recompilation
+    syntax.ss, record.ss, primdata.ss, misc.ms, system.stex

csug/system.stex

@@ -2119,6 +2119,115 @@ loaded from source, when it is compiled via \scheme{compile-file},
 and when a compiled version of the file is loaded via \scheme{load}
 or \scheme{visit}.
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{current-generate-id}{\categorythreadparameter}{current-generate-id}
+\listlibraries
+\endentryheader
+
+\noindent
+This parameter determines a procedure that is called by the macro
+expander. The procedure receives a symbol and returns a fresh symbol
+that the expander uses for a top-level binding, as a record uid,
+or to identify a library compilation. The default procedure converts the
+symbol to a string and passes it to \scheme{gensym}.
+
+For example, while expanding the following \scheme{library}, the
+\scheme{current-generate-id} procedure is called on the symbols
+\scheme{a-lib}, \scheme{a-var}, and \scheme{a-var} again.
+
+\schemedisplay
+(library (a-lib)
+  (export a-var)
+  (import (chezscheme))
+  (define a-var 3)
+  (define-syntax def
+    (syntax-rules ()
+      [(_) (define a-var 'other)]))
+  (def))
+\endschemedisplay
+
+The \scheme{current-generate-id} procedure is called on \scheme{a-lib}
+to generate a symbol that identifies this particular library
+compilation, as opposed to the compilation of a different library
+named \scheme{(a-lib)}. It is called on \scheme{a-var} the first time
+to select a distinct symbol to hold the value of the \scheme{a-var}
+defininion, since \scheme{a-var} itself should not be defined directly
+at the top level. Finally, the \scheme{current-generate-id} procedure
+is called on \scheme{a-var} to select a name for the macro-introduced
+definiton of \scheme{a-var} in the expansion of \scheme{(def)}---which
+turns out to be completely inaccessible since no reference is
+introduced by the same expansion step.
+
+Setting the parameter to a particular, deterministic generator can
+cause symbols in the expansion of the library to be always the
+same. That determinism can be helpful if the expansion semantically
+matches an earlier expansion, so that uses of an earlier compilation
+remain compatible with the new one. Of course, reusing a symbol runs
+the risk of creating collisions that the macro and library system
+normally prevents via distinct symbols, and compiler optimizations may
+rely on the expectation of distinct symbols for distinct compilations.
+Configure \scheme{current-generate-id} at your own risk.
+
+As a further example, suppose that the following two forms are
+compiled separately:
+
+\schemedisplay
+;; Compile this x.ss to x.so
+(library (x)
+  (export x)
+  (import (chezscheme))
+  (define x '(x)))
+
+;; Compile this y.ss to y.so
+(top-level-program
+ (import (chezscheme)
+         (y))
+ (printf "~s\n" x))
+\endschemedisplay
+
+If \scheme{x.ss} is modified and recompiled, loading the new
+\scheme{x.so} and the old \scheme{y.so} will correctly report an error
+that the compiled \scheme{y.so} requires a different compilation
+instance that the one already loaded.
+
+Suppose, however, that you're willing to live dangerously to avoid
+recompiling \scheme{y.ss} by generating the same symbols for every
+compilation of \scheme{x.ss}. While compiling \scheme{x.ss}, you could
+set \scheme{current-generate-id} to the result of
+\scheme{make-x-generator}:
+
+\schemedisplay
+(define (make-x-generator)
+  (let ([x-uid "gf91a5b83ujz3mogjdaij7-x"]
+        [counter-ht (make-eq-hashtable)])
+    (lambda (sym)
+      (let* ([n (eq-hashtable-ref counter-ht sym 0)]
+             [s ((if (gensym? sym) gensym->unique-string symbol->string) sym)]
+             [g (gensym (symbol->string sym) (format "~a-~a-~a" x-uid s n))])
+        (eq-hashtable-set! counter-ht sym (+ n 1))
+        g))))
+\endschemedisplay
+
+As long as the first and second compilations of \scheme{x.ss} use the
+result of \scheme{make-x-generator}, the first compilation of
+\scheme{y.ss} might work with the second compilation of \scheme{x.ss},
+even if the change adds, removes, or reorders definitions of variables
+other than \scheme{x}.
+
+Beware that if the variable \scheme{x} is originally defined as
+\scheme{(define x 1)}, then the compilation of \scheme{y.ss} likely
+inlines the value \scheme{1} in place of its reference to the variable
+\scheme{x}, so changing \scheme{x.ss} will have no effect without
+recompiling \scheme{y.ss}. Similarly, if the change to \scheme{x.ss}
+deletes the definition of \scheme{x} or introduces a macro-generated
+definition of \scheme{x} before the direct definition, then the
+previously compiled \scheme{y.ss} is unlikely to refer to the correct
+definition of \scheme{x} in the new compilation of \scheme{x.ss}.
+Configure \scheme{make-x-generator} this way only in situations where
+the potential for unspecified failure is more tolerable than
+recompilation.
+
 \section{Source Directories and Files\label{SECTSYSTEMSOURCE}}
 
 %----------------------------------------------------------------------------

mats/misc.ms

@@ -4994,3 +4994,50 @@
   (mutable-bytevector? '#vu8())
   
  )
+
+(mat current-generate-id
+  (begin
+    (define (make-x-generator)
+      (let ([x-uid "gf91a5b83ujz3mogjdaij7-x"]
+            [counter-ht (make-eq-hashtable)])
+        (lambda (sym)
+          (let* ([n (eq-hashtable-ref counter-ht sym 0)]
+                 [str (if (gensym? sym) (gensym->unique-string sym) (symbol->string sym))]
+                 [g (gensym (symbol->string sym) (format "~a-~a-~a" x-uid str n))])
+            (eq-hashtable-set! counter-ht sym (+ n 1))
+            g))))
+    (and (parameterize ([current-generate-id (make-x-generator)])
+           (eval `(module consistent-x (x make-pt pt-r)
+                    ;; Note: `module` doesn't currently enable `x` to be inlined
+                    (define x 1)
+                    (define-record-type pt (fields r i)))))
+         #t))
+  (begin
+    (define return-x (let ()
+                       (import consistent-x)
+                       (lambda () x)))
+    (define a-pt (let ()
+                   (import consistent-x)
+                   (make-pt -1 -2)))
+    (define get-r (let ()
+                    (import consistent-x)
+                    (lambda (p) (pt-r p))))
+    (equal? 1 (return-x)))
+  (equal? -1 (get-r a-pt))
+  (begin
+    (parameterize ([current-generate-id (make-x-generator)])
+      (eval `(module consistent-x (x make-pt pt-x)
+               (define x 2)
+               (define-record-type pt (fields x y)))))
+    (equal? 2 (return-x)))
+  (equal? -1 (get-r a-pt))
+  (begin
+    (parameterize ([current-generate-id (make-x-generator)])
+      (eval `(module consistent-x (x)
+               (define x 3)
+               (define-syntax def (syntax-rules () [(_) (define x 'other)]))
+               ;; `(def)` after above definition => expect that
+               ;; its `x` is generated second
+               (def))))
+    (equal? 3 (return-x)))
+)

s/primdata.ss

@@ -935,6 +935,7 @@
   (current-eval [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
   (current-exception-state [sig [() -> (exception-state)] [(exception-state) -> (void)]] [flags])
   (current-expand [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
+  (current-generate-id [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
   (current-input-port [sig [() -> (textual-input-port)] [(textual-input-port) -> (void)]] [flags])   ; not restricted to 1 argument
   (current-locate-source-object-source [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
   (current-make-source-object [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])

s/record.ss

@@ -395,6 +395,15 @@
           (rec predicate (lambda (x) ($sealed-record? x rtd)))
           (rec predicate (lambda (x) (record? x rtd))))))
 
+  (set-who! current-generate-id
+    ($make-thread-parameter
+     (lambda (sym)
+       (unless (symbol? sym) ($oops 'default-generate-id "~s is not a symbol" sym))
+       (gensym (symbol->string sym)))
+     (lambda (p)
+       (unless (procedure? p) ($oops who "~s is not a procedure" p))
+       p)))
+
   (let ((base-rtd #!base-rtd))
     (define (make-flags uid sealed? opaque? parent)
       (fxlogor
@@ -408,7 +417,7 @@
       (when (and parent (record-type-sealed? parent))
         ($oops who "cannot extend sealed record type ~s" parent))
       (let ([parent-fields (if (not parent) '() (csv7:record-type-field-decls parent))]
-            [uid (or uid (gensym (symbol->string name)))])
+            [uid (or uid ((current-generate-id) name))])
        ; start base offset at rtd field
        ; synchronize with syntax.ss and front.ss
         (let-values ([(pm mpm flds size)

s/syntax.ss

@@ -469,7 +469,7 @@
 
 (define generate-id
   (lambda (sym)
-    (gensym (symbol->string sym))))
+    ((current-generate-id) sym)))
 
 (define make-token:sym
   (lambda (token sym)