Merge branch 'genid' of github.com:mflatt/ChezScheme

original commit: 53b38c5cf56ba225c8366c23f8141e52e23451c9

LOG

@@ -997,3 +997,6 @@
     cmacros.ss, compile.ss, cpnanopass.ss, inspect.ss,
     primdata.ss, prims.ss, misc.ms,
     system.stex, release_notes.tex
+- add current-generate-id and expand-omit-library-invocations, which can be
+  useful for avoiding library recompilation and redundant invocation checks
+    syntax.ss, record.ss, primdata.ss, front.ss, misc.ms, system.stex

csug/system.stex

@@ -2120,6 +2120,136 @@ 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.
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{expand-omit-library-invocations}{\categorythreadparameter}{expand-omit-library-invocations}
+\listlibraries
+\endentryheader
+
+\noindent
+This boolean-valued parameter determines whether library uses are
+recorded in macro expansion. Normally, when an expression expands to a
+reference to a library-defined identifier, the expansion is prefixed
+with a check to ensure that the exporting library is defined and
+invoked. If \scheme{expand-omit-library-invocations} is set to true,
+the prefix is omitted.
+
+Setting \scheme{expand-omit-library-invocations} to true makes sense
+only when evaluating many small expressions in a context where all
+referenced libraries are known to be present and already invoked, and
+only when it's worth saving the small overhead of representing and
+running the check.
+
+
 \section{Source Directories and Files\label{SECTSYSTEMSOURCE}}
 
 %----------------------------------------------------------------------------

mats/misc.ms

@@ -5105,3 +5105,71 @@
   (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)))
+)
+
+(mat expand-omit-library-invocations
+  (not (expand-omit-library-invocations))
+  (begin
+    (library (define-m-as-one) (export m) (import (chezscheme)) (define m 1))
+    (define (find-define-m-as-one s)
+      (or (eq? s 'define-m-as-one)
+          (and (pair? s)
+                (or (find-define-m-as-one (car s))
+                        (find-define-m-as-one (cdr s))))))
+    #t)
+  (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m)))
+  (begin
+    (expand-omit-library-invocations 'yes)
+    (eq? #t (expand-omit-library-invocations)))
+  (not (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m))))
+  (begin
+    (expand-omit-library-invocations #f)
+    (not (expand-omit-library-invocations)))
+  (find-define-m-as-one (expand '(let () (import (define-m-as-one)) m)))
+  )

s/front.ss

@@ -104,6 +104,15 @@
 
 (define enable-cross-library-optimization ($make-thread-parameter #t (lambda (x) (and x #t))))
 
+(define-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)))
+
 (define machine-type
   (lambda ()
     (constant machine-type-name)))

s/patch.ss

@@ -18,6 +18,7 @@
   (case-lambda
    [() #f]
    [(v) (void)]))
+(define current-generate-id (make-parameter (lambda (s) (gensym (symbol->string s)))))
 
 (printf "loading ~s cross compiler~%" (constant machine-type-name))
 

s/primdata.ss

@@ -936,6 +936,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])
@@ -950,6 +951,7 @@
   (enable-object-backreferences [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
   (enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
   (eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags])
+  (expand-omit-library-invocations [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
   (expand-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags])
   (expand/optimize-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags])
   (exit-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])

s/record.ss

@@ -408,7 +408,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)
@@ -3447,7 +3447,12 @@
 
 (define residualize-invoke-requirements
   (case-lambda
-    [(code) (residualize-invoke-requirements '() (require-visit) (require-invoke) code)]
+    [(code) (residualize-invoke-requirements '()
+                                             (require-visit)
+                                             (if (expand-omit-library-invocations)
+                                                 '()
+                                                 (require-invoke))
+                                             code)]
     [(import* visit* invoke* code)
      (build-sequence no-source
        `(,@(map (build-requirement '$import-library) import*)
@@ -4993,6 +4998,10 @@
     (lambda ()
       (list-loaded-libraries)))
 
+  (set! expand-omit-library-invocations
+    ($make-thread-parameter #f
+      (lambda (v) (and v #t))))
+
   (let ()
     (define maybe-get-lib
       (lambda (who libref)
@@ -9451,7 +9460,7 @@
                    (begin
                      (when (any-set? keys-seen (clause-key nongenerative))
                        (syntax-error src "record definition has multiple nongenerative clauses"))
-                     (Mclause parse-clauses ([%uid (datum->syntax #'* (gensym (symbol->string (syntax->datum name))))])
+                     (Mclause parse-clauses ([%uid (datum->syntax #'* ((current-generate-id) (syntax->datum name)))])
                        (set-flags keys-seen (clause-key nongenerative))
                        (cdr clause*)))]
                   [(nongenerative id)