mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

psyntax: Use vectors instead of gensyms for labels, marks

Browse source 
* module/ice-9/psyntax.scm (gen-unique): Instead of making a string with
an embedded hex counter, make a vector.  A little less work than making
a string, and slightly smaller binaries.
(gen-label, gen-mark): Use gen-unique.
(resolve-identifier): Adapt case that recognizes labels denoting
lexicals to be less strict.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-14 15:58:21 +01:00
parent 70e2616975
commit d60aeb3ced
2 changed files with 84 additions and 61 deletions
Download patch file Download diff file Expand all files Collapse all files

112
module/ice-9/psyntax-pp.scm
View file

@ -174,7 +174,12 @@
(if (syntax? x) (if (syntax? x)
(values (syntax-expression x) (join-marks (car w) (car (syntax-wrap x)))) (values (syntax-expression x) (join-marks (car w) (car (syntax-wrap x))))
(values x (car w))))) (values x (car w)))))
(gen-label (lambda () (symbol->string (module-gensym "l")))) (gen-unique
(lambda* (#:optional (module (current-module)))
(if module
(vector (module-name module) (module-generate-unique-id! module))
(vector '(guile) (gensym "id")))))
(gen-label (lambda () (gen-unique)))
(gen-labels (lambda (ls) (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls)))))) (gen-labels (lambda (ls) (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
(make-ribcage (lambda (symnames marks labels) (vector 'ribcage symnames marks labels))) (make-ribcage (lambda (symnames marks labels) (vector 'ribcage symnames marks labels)))
(ribcage? (lambda (x) (and (vector? x) (= (vector-length x) 4) (eq? (vector-ref x 0) 'ribcage)))) (ribcage? (lambda (x) (and (vector? x) (= (vector-length x) 4) (eq? (vector-ref x 0) 'ribcage))))
@ -185,6 +190,7 @@
(set-ribcage-marks! (lambda (x update) (vector-set! x 2 update))) (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update)))
(set-ribcage-labels! (lambda (x update) (vector-set! x 3 update))) (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update)))
(anti-mark (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w))))) (anti-mark (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w)))))
(new-mark (lambda () (gen-unique)))
(extend-ribcage! (extend-ribcage!
(lambda (ribcage id label) (lambda (ribcage id label)
(set-ribcage-symnames! ribcage (cons (syntax-expression id) (ribcage-symnames ribcage))) (set-ribcage-symnames! ribcage (cons (syntax-expression id) (ribcage-symnames ribcage)))
@ -343,8 +349,7 @@
(or (syntax-module n) mod) (or (syntax-module n) mod)
resolve-syntax-parameters?))) resolve-syntax-parameters?)))
((symbol? n) (resolve-global n (or (and (syntax? id) (syntax-module id)) mod))) ((symbol? n) (resolve-global n (or (and (syntax? id) (syntax-module id)) mod)))
((string? n) (resolve-lexical n (or (and (syntax? id) (syntax-module id)) mod))) (else (resolve-lexical n (or (and (syntax? id) (syntax-module id)) mod))))))))
(else (error "unexpected id-var-name" id w n)))))))
(transformer-environment (transformer-environment
(make-fluid (lambda (k) (error "called outside the dynamic extent of a syntax transformer")))) (make-fluid (lambda (k) (error "called outside the dynamic extent of a syntax transformer"))))
(with-transformer-environment (lambda (k) ((fluid-ref transformer-environment) k))) (with-transformer-environment (lambda (k) ((fluid-ref transformer-environment) k)))
@ -795,12 +800,12 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-df5 transformer-environment) (let* ((t-680b775fb37a463-df3 transformer-environment)
(t-680b775fb37a463-df6 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-df4 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-df5 t-680b775fb37a463-df3
t-680b775fb37a463-df6 t-680b775fb37a463-df4
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (module-gensym "m")))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" placeholder) r)) (let* ((r (cons '("placeholder" placeholder) r))
@ -1329,11 +1334,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-2 (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463-1 tmp-680b775fb37a463
tmp-680b775fb37a463) tmp-680b775fb37a463-106f)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-106f
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1601,8 +1606,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-6b8 tmp-680b775fb37a463-6b7 tmp-680b775fb37a463-6b6) (map (lambda (tmp-680b775fb37a463-6b4 tmp-680b775fb37a463-6b3 tmp-680b775fb37a463-6b2)
(cons tmp-680b775fb37a463-6b6 (cons tmp-680b775fb37a463-6b7 tmp-680b775fb37a463-6b8))) (cons tmp-680b775fb37a463-6b2 (cons tmp-680b775fb37a463-6b3 tmp-680b775fb37a463-6b4)))
e2 e2
e1 e1
args))) args)))
@ -1612,9 +1617,9 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-6ce tmp-680b775fb37a463-6cd tmp-680b775fb37a463-6cc) (map (lambda (tmp-680b775fb37a463-6ca tmp-680b775fb37a463-6c9 tmp-680b775fb37a463-6c8)
(cons tmp-680b775fb37a463-6cc (cons tmp-680b775fb37a463-6c8
(cons tmp-680b775fb37a463-6cd tmp-680b775fb37a463-6ce))) (cons tmp-680b775fb37a463-6c9 tmp-680b775fb37a463-6ca)))
e2 e2
e1 e1
args))) args)))
@ -1634,8 +1639,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-67e tmp-680b775fb37a463-67d tmp-680b775fb37a463-67c)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463-67c (cons tmp-680b775fb37a463-67d tmp-680b775fb37a463-67e)))
e2 e2
e1 e1
args))) args)))
@ -2427,8 +2432,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463 tmp-680b775fb37a463-118f tmp-680b775fb37a463-118e) (map (lambda (tmp-680b775fb37a463-118d tmp-680b775fb37a463-118c tmp-680b775fb37a463-118b)
(list (cons tmp-680b775fb37a463-118e tmp-680b775fb37a463-118f) tmp-680b775fb37a463)) (list (cons tmp-680b775fb37a463-118b tmp-680b775fb37a463-118c)
tmp-680b775fb37a463-118d))
template template
pattern pattern
keyword))) keyword)))
@ -2443,11 +2449,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11a9 (map (lambda (tmp-680b775fb37a463-11a6
tmp-680b775fb37a463-11a8 tmp-680b775fb37a463-11a5
tmp-680b775fb37a463-11a7) tmp-680b775fb37a463-11a4)
(list (cons tmp-680b775fb37a463-11a7 tmp-680b775fb37a463-11a8) (list (cons tmp-680b775fb37a463-11a4 tmp-680b775fb37a463-11a5)
tmp-680b775fb37a463-11a9)) tmp-680b775fb37a463-11a6))
template template
pattern pattern
keyword))) keyword)))
@ -2459,11 +2465,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-11c2 (map (lambda (tmp-680b775fb37a463-11bf
tmp-680b775fb37a463-11c1 tmp-680b775fb37a463-11be
tmp-680b775fb37a463-11c0) tmp-680b775fb37a463-11bd)
(list (cons tmp-680b775fb37a463-11c0 tmp-680b775fb37a463-11c1) (list (cons tmp-680b775fb37a463-11bd tmp-680b775fb37a463-11be)
tmp-680b775fb37a463-11c2)) tmp-680b775fb37a463-11bf))
template template
pattern pattern
keyword))) keyword)))
@ -2479,11 +2485,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11e1 (map (lambda (tmp-680b775fb37a463-11de
tmp-680b775fb37a463-11e0 tmp-680b775fb37a463-11dd
tmp-680b775fb37a463-11df) tmp-680b775fb37a463-11dc)
(list (cons tmp-680b775fb37a463-11df tmp-680b775fb37a463-11e0) (list (cons tmp-680b775fb37a463-11dc tmp-680b775fb37a463-11dd)
tmp-680b775fb37a463-11e1)) tmp-680b775fb37a463-11de))
template template
pattern pattern
keyword))) keyword)))
@ -2611,9 +2617,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-128e) (map (lambda (tmp-680b775fb37a463-128b)
(list "value" (list "value"
tmp-680b775fb37a463-128e)) tmp-680b775fb37a463-128b))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2677,8 +2683,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-12a9) (map (lambda (tmp-680b775fb37a463-12a6)
(list "value" tmp-680b775fb37a463-12a9)) (list "value" tmp-680b775fb37a463-12a6))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2698,8 +2704,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-12ae) (map (lambda (tmp-680b775fb37a463-12ab)
(list "value" tmp-680b775fb37a463-12ae)) (list "value" tmp-680b775fb37a463-12ab))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2781,8 +2787,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12f7) (apply (lambda (t-680b775fb37a463-12f4)
(cons "vector" t-680b775fb37a463-12f7)) (cons "vector" t-680b775fb37a463-12f4))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2803,8 +2809,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463 tmp)) (let ((t-680b775fb37a463-130f tmp))
(list "list->vector" t-680b775fb37a463))))))))))))))))) (list "list->vector" t-680b775fb37a463-130f)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -2816,9 +2822,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-131e)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-131e))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2853,12 +2859,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-133e)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-133e))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2871,12 +2877,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-134d) (apply (lambda (t-680b775fb37a463-134a)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-134d)) t-680b775fb37a463-134a))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

33
module/ice-9/psyntax.scm
View file

@ -536,10 +536,29 @@
(define-syntax wrap-marks (identifier-syntax car)) (define-syntax wrap-marks (identifier-syntax car))
(define-syntax wrap-subst (identifier-syntax cdr)) (define-syntax wrap-subst (identifier-syntax cdr))
(define* (gen-unique #:optional (module (current-module)))
;; Generate a unique value, used as a mark to identify a scope, or
;; as a label to associate an identifier with a lexical. They
;; need to be readable and writable, and because of they way they
;; are used as labels and marks, distinct from pairs, syntax, and
;; the symbol `top'. Unique values from different separately
;; compiled modules can coexist, for example if a macro defined in
;; module A is used in a separately-compiled module B; however we
;; assume that generally a module corresponds to a compilation
;; unit, so there is no need to be unique across
;; separately-compiled instances of the same module, and that
;; therefore we can use a deterministic per-module counter instead
;; of, say, a random number of a long enough length.
(if module
(vector (module-name module) (module-generate-unique-id! module))
(vector '(guile) (gensym "id"))))
;; labels must be comparable with "eq?", have read-write invariance, ;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols. ;; and distinct from symbols. Pair labels are used for top-level
;; definition placeholders. These labels are used for proper
;; lexicals.
(define (gen-label) (define (gen-label)
(symbol->string (module-gensym "l"))) (gen-unique))
(define gen-labels (define gen-labels
(lambda (ls) (lambda (ls)
@ -563,8 +582,8 @@
(make-wrap (cons the-anti-mark (wrap-marks w)) (make-wrap (cons the-anti-mark (wrap-marks w))
(cons 'shift (wrap-subst w))))) (cons 'shift (wrap-subst w)))))
(define-syntax-rule (new-mark) (define (new-mark)
(module-gensym "m")) (gen-unique))
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;; internal definitions, in which the ribcages are built incrementally ;; internal definitions, in which the ribcages are built incrementally
@ -860,12 +879,10 @@
(resolve-global n (or (and (syntax? id) (resolve-global n (or (and (syntax? id)
(syntax-module id)) (syntax-module id))
mod))) mod)))
((string? n) (else
(resolve-lexical n (or (and (syntax? id) (resolve-lexical n (or (and (syntax? id)
(syntax-module id)) (syntax-module id))
mod))) mod))))))
(else
(error "unexpected id-var-name" id w n)))))
(define transformer-environment (define transformer-environment
(make-fluid (make-fluid