From fa4f48a82ca1458fbe520f9f74587bbc0552f025 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 3 Sep 2010 04:14:36 -0600 Subject: [PATCH] id-tables can work at different phases now reduced allocation for id-table updates --- collects/syntax/id-table.rkt | 6 +- collects/syntax/private/id-table.rkt | 168 ++++++++++++--------- collects/syntax/scribblings/id-table.scrbl | 21 ++- 3 files changed, 119 insertions(+), 76 deletions(-) diff --git a/collects/syntax/id-table.rkt b/collects/syntax/id-table.rkt index 95ac8b05ed..5a1e25029a 100644 --- a/collects/syntax/id-table.rkt +++ b/collects/syntax/id-table.rkt @@ -45,8 +45,8 @@ mutable-idtbl? immutable-idtbl?) (provide/contract - [make-idtbl (->* () (dict?) any)] - [make-immutable-idtbl (->* () (dict?) any)] + [make-idtbl (->* () (dict? #:phase (or/c exact-integer? #f)) any)] + [make-immutable-idtbl (->* () (dict? #:phase (or/c exact-integer? #f)) any)] [idtbl-ref (->* (idtbl? any/c) (any/c) any)] [idtbl-set! (-> mutable-idtbl? any/c any/c @@ -69,4 +69,4 @@ (make-code bound-id-table) (make-code free-id-table) -(make-code free*-id-table) +;; (make-code free*-id-table) diff --git a/collects/syntax/private/id-table.rkt b/collects/syntax/private/id-table.rkt index 58a5426ee1..4ffb253701 100644 --- a/collects/syntax/private/id-table.rkt +++ b/collects/syntax/private/id-table.rkt @@ -42,6 +42,46 @@ (apply f args)) name) arity)) +;; ======== + +;; Inline alist operations... +;; id, v args must be variables (to avoid duplicating expressions) + +(define-syntax-rule (alist-set identifier=? phase l0 id v) + ;; To minimize allocation + ;; - add new pairs to front + ;; - avoid allocation on idempotent sets + (let* ([not-found? #f] + [new-l + (let loop ([l l0]) + (cond [(null? l) (begin (set! not-found? #t) null)] + [(identifier=? (caar l) id phase) + (if (eq? v (cdar l)) ;; idempotent; just leave it alone + l + (cons (cons id v) (cdr l)))] + [else + (let ([rest* (loop (cdr l))]) + (if (eq? (cdr l) rest*) + l + (cons (car l) rest*)))]))]) + (if not-found? + (cons (cons id v) l0) + new-l))) + +(define-syntax-rule (alist-remove identifier=? phase l0 id) + ;; To minimize allocation + ;; - avoid allocation on idempotent removes + (let loop ([l l0]) + (cond [(null? l) null] + [(identifier=? (caar l) id phase) + (cdr l)] + [else + (let ([rest* (loop (cdr l))]) + (if (eq? (cdr l) rest*) + l + (cons (car l) rest*)))]))) + +;; ======== (define-syntax (make-code stx) (syntax-case stx () @@ -65,6 +105,7 @@ (define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x)) (with-syntax ([idtbl? (s '?)] [idtbl-hash (s '-hash)] + [idtbl-phase (s '-phase)] [idtbl-ref (s '-ref)] [idtbl-set! (s '-set!)] [idtbl-set (s '-set)] @@ -83,86 +124,71 @@ (define mk (let ([make-idtbl - (case-lambda - [() (mk null)] - [(init-dict) - (let ([t (make-mutable-idtbl (make-hasheq))]) - (for ([(k v) (in-dict init-dict)]) - (idtbl-set! t k v)) - t)])]) + (lambda ([init-dict null] #:phase [phase (syntax-local-phase-level)]) + (let ([t (make-mutable-idtbl (make-hasheq) phase)]) + (for ([(k v) (in-dict init-dict)]) + (idtbl-set! t k v)) + t))]) make-idtbl)) (define mkimm (let ([make-immutable-idtbl - (case-lambda - [() (mkimm null)] - [(init-dict) - (for/fold ([t (make-immutable-idtbl empty-immutable-hasheq)]) - ([(k v) (in-dict init-dict)]) - (idtbl-set t k v))])]) + (lambda ([init-dict null] #:phase [phase (syntax-local-phase-level)]) + (for/fold ([t (make-immutable-idtbl empty-immutable-hasheq phase)]) + ([(k v) (in-dict init-dict)]) + (idtbl-set t k v)))]) make-immutable-idtbl)) (define (idtbl-ref d id [fail (lambda () (error 'idtbl-ref "no mapping for ~e" id))]) - (let ([i (ormap (lambda (i) (and (identifier=? (car i) id) i)) - (hash-ref (idtbl-hash d) - (identifier->symbol id) - null))]) - (if i - (cdr i) - (if (procedure? fail) - (fail) - fail)))) + (let ([phase (idtbl-phase d)]) + (let ([i (ormap (lambda (i) (and (identifier=? (car i) id phase) i)) + (hash-ref (idtbl-hash d) + (identifier->symbol id phase) + null))]) + (if i + (cdr i) + (if (procedure? fail) + (fail) + fail))))) (define (idtbl-set! d id v) - (let ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)]) + (let* ([phase (idtbl-phase d)] + [sym (identifier->symbol id phase)] + [l (hash-ref (idtbl-hash d) sym null)]) (hash-set! (idtbl-hash d) - (identifier->symbol id) - (let loop ([l l]) - (cond [(null? l) (list (cons id v))] - [(identifier=? (caar l) id) - (cons (cons id v) (cdr l))] - [else (cons (car l) (loop (cdr l)))]))))) + sym + (alist-set identifier=? phase l id v)))) (define (idtbl-set d id v) - (let ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)]) + (let* ([phase (idtbl-phase d)] + [sym (identifier->symbol id phase)] + [l (hash-ref (idtbl-hash d) sym null)]) (make-immutable-idtbl (hash-set (idtbl-hash d) - (identifier->symbol id) - (let loop ([l l]) - (cond [(null? l) (list (cons id v))] - [(identifier=? (caar l) id) - (cons (cons id v) (cdr l))] - [else (cons (car l) (loop (cdr l)))])))))) + sym + (alist-set identifier=? phase l id v)) + phase))) (define (idtbl-remove! d id) - (let* ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)] - [newl (let loop ([l l]) - (cond [(null? l) null] - [(identifier=? (caar l) id) - (cdr l)] - [else (cons (car l) (loop (cdr l)))]))]) + (let* ([phase (idtbl-phase d)] + [sym (identifier->symbol id phase)] + [l (hash-ref (idtbl-hash d) sym null)] + [newl (alist-remove identifier=? phase l id)]) (if (pair? newl) - (hash-set! (idtbl-hash d) - (identifier->symbol id) - newl) - (hash-remove! (idtbl-hash d) - (identifier->symbol id))))) + (hash-set! (idtbl-hash d) sym newl) + (hash-remove! (idtbl-hash d) sym)))) (define (idtbl-remove d id) - (let* ([l (hash-ref (idtbl-hash d) (identifier->symbol id) null)] - [newl (let loop ([l l]) - (cond [(null? l) null] - [(identifier=? (caar l) id) - (cdr l)] - [else (cons (car l) (loop (cdr l)))]))]) + (let* ([phase (idtbl-phase d)] + [sym (identifier->symbol id phase)] + [l (hash-ref (idtbl-hash d) sym null)] + [newl (alist-remove identifier=? phase l id)]) (make-immutable-idtbl (if (pair? newl) - (hash-set (idtbl-hash d) - (identifier->symbol id) - newl) - (hash-remove (idtbl-hash d) - (identifier->symbol id)))))) + (hash-set (idtbl-hash d) sym newl) + (hash-remove (idtbl-hash d) sym)) + phase))) (define (idtbl-count d) (apply + (hash-map (idtbl-hash d) (lambda (k v) (length v))))) @@ -221,7 +247,7 @@ (unless (immutable-idtbl? x) (raise-type-error who (symbol->string 'immutable-idtbl) x))) - (define-struct idtbl (hash)) + (define-struct idtbl (hash phase)) (define-struct (mutable-idtbl idtbl) () #:property prop:dict (vector (wrap idtbl-ref (list check-idtbl check-id void) '(2 3)) @@ -265,14 +291,14 @@ idtbl-map idtbl-for-each))))])) -(define (bound-identifier->symbol id) (syntax-e id)) +(define (bound-identifier->symbol id phase) (syntax-e id)) (make-code bound-id-table bound-identifier->symbol bound-identifier=?) -(define (free-identifier->symbol id) - (let ([binding (identifier-binding id)]) +(define (free-identifier->symbol id phase) + (let ([binding (identifier-binding id phase)]) (if (pair? binding) (cadr binding) (syntax-e id)))) @@ -281,21 +307,25 @@ free-identifier->symbol free-identifier=?) -(define (resolve id) - (if (syntax-transforming?) +#| +;; free*-id-tables only phase = (syntax-local-phase-level) + +(define (resolve id phase) + (if (and (syntax-transforming?) (equal? phase (syntax-local-phase-level))) (let-values ([(v next) (syntax-local-value/immediate id (lambda () (values #f #f)))]) (if next - (resolve next) + (resolve next phase) id)) id)) -(define (free*-identifier->symbol id) - (free-identifier->symbol (resolve id))) +(define (free*-identifier->symbol id phase) + (free-identifier->symbol (resolve id phase) phase)) -(define (free*-identifier=? a b) - (free-identifier=? (resolve a) (resolve b))) +(define (free*-identifier=? a b phase) + (free-identifier=? (resolve a phase) (resolve b phase) phase)) (make-code free*-id-table free*-identifier->symbol free*-identifier=?) +|# diff --git a/collects/syntax/scribblings/id-table.scrbl b/collects/syntax/scribblings/id-table.scrbl index 81221d5b4f..bb5e378903 100644 --- a/collects/syntax/scribblings/id-table.scrbl +++ b/collects/syntax/scribblings/id-table.scrbl @@ -20,9 +20,13 @@ functions (@scheme[dict-ref], @scheme[dict-map], etc) can be used on free-identifier tables. @deftogether[[ -@defproc[(make-bound-id-table [init-dict dict? null]) +@defproc[(make-bound-id-table + [init-dict dict? null] + [#:phase phase (or/c exact-integer? #f) (syntax-local-phase-level)]) mutable-bound-id-table?] -@defproc[(make-immutable-bound-id-table [init-dict dict? null]) +@defproc[(make-immutable-bound-id-table + [init-dict dict? null] + [#:phase phase (or/c exact-integer? #f) (syntax-local-phase-level)]) immutable-bound-id-table?]]]{ Produces a dictionary mapping syntax identifiers to arbitrary @@ -31,6 +35,11 @@ but also uses a hash table based on symbol equality to make the mapping efficient in the common case. The two procedures produce mutable and immutable dictionaries, respectively. +The identifiers are compared at phase level @scheme[phase]. The +default value is generally appropriate for identifier tables used by +macros, but code that analyzes fully-expanded programs may need to +create identifier tables at multiple different phases. + The optional @scheme[init-dict] argument provides the initial mappings. It must be a dictionary, and its keys must all be identifiers. If the @scheme[init-dict] dictionary has multiple @@ -146,9 +155,13 @@ functions (@scheme[dict-ref], @scheme[dict-map], etc) can be used on free-identifier tables. @deftogether[[ -@defproc[(make-free-id-table [init-dict dict? null]) +@defproc[(make-free-id-table + [init-dict dict? null] + [#:phase phase (or/c exact-integer? #f) (syntax-local-phase-level)]) mutable-free-id-table?] -@defproc[(make-immutable-free-id-table [init-dict dict? null]) +@defproc[(make-immutable-free-id-table + [init-dict dict? null] + [#:phase phase (or/c exact-integer? #f) (syntax-local-phase-level)]) immutable-free-id-table?] @defproc[(free-id-table? [v any/c]) boolean?] @defproc[(mutable-free-id-table? [v any/c]) boolean?]