diff --git a/LOG b/LOG index cb80ff6789..0cac43e02a 100644 --- a/LOG +++ b/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 diff --git a/csug/system.stex b/csug/system.stex index da12059364..3a001937f7 100644 --- a/csug/system.stex +++ b/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}} %---------------------------------------------------------------------------- diff --git a/mats/misc.ms b/mats/misc.ms index 916be1e63d..935aa21a9d 100644 --- a/mats/misc.ms +++ b/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))) + ) diff --git a/s/front.ss b/s/front.ss index 1ca36b0769..5a2bb670e7 100644 --- a/s/front.ss +++ b/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))) diff --git a/s/patch.ss b/s/patch.ss index 68f47fad24..63d25824a4 100644 --- a/s/patch.ss +++ b/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)) diff --git a/s/primdata.ss b/s/primdata.ss index 9f635a9c44..d12f1b784e 100644 --- a/s/primdata.ss +++ b/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]) diff --git a/s/record.ss b/s/record.ss index 3849c55d4b..477bf316f8 100644 --- a/s/record.ss +++ b/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) diff --git a/s/syntax.ss b/s/syntax.ss index 119c6e51a7..95ed9ba098 100644 --- a/s/syntax.ss +++ b/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)