diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index bc3cc8c..1472069 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -250,30 +250,46 @@ id)) elems)))))) + (define (intern-vector intern-box v) + (if (and intern-box + (andmap symbol? (vector->list v))) + (or (ormap (lambda (i) + (and (equal? v (cadr i)) + (list 'unquote (car i)))) + (unbox intern-box)) + (let ([name (car (generate-temporaries '(idvec)))]) + (set-box! intern-box + (cons (list name v) + (unbox intern-box))) + (list 'unquote name))) + v)) + (define explode-sig - (lambda (sig) - (list->vector - (map - (lambda (v) - (if (symbol? v) - v - (cons - (signature-name v) - (explode-sig v)))) - (signature-elems sig))))) + (lambda (sig intern-box) + (intern-vector + intern-box + (list->vector + (map + (lambda (v) + (if (symbol? v) + v + (cons + (signature-name v) + (explode-sig v intern-box)))) + (signature-elems sig)))))) (define explode-named-sig - (lambda (s) + (lambda (s intern-box) (cons (cond [(signature-name s)] [(signature-src s)] [else inline-sig-name]) - (explode-sig s)))) + (explode-sig s intern-box)))) (define explode-named-sigs - (lambda (sigs) - (map explode-named-sig sigs))) + (lambda (sigs intern-box) + (map (lambda (sig) (explode-named-sig sig intern-box)) sigs))) (define sort-signature-elems (lambda (elems) @@ -611,9 +627,9 @@ (verify-signature-match 'compound-unit/sig #f (format "signature ~s" (signature-src use-sig)) - (explode-sig use-sig) + (explode-sig use-sig #f) (format "signature ~s" (signature-src sig)) - (explode-sig sig)))))] + (explode-sig sig #f)))))] [flatten-subpath (lambda (base last use-sig name sig p) (cond @@ -893,7 +909,8 @@ (format "bad `export' sub-clause") export)])) - export-list)]) + export-list)] + [interned-vectors (box null)]) (check-unique (map (lambda (s) (if (signature? s) @@ -908,11 +925,11 @@ name))) (values (map link-name links) (map link-expr links) - (map (lambda (link) (explode-sig (link-sig link))) links) + (map (lambda (link) (explode-sig (link-sig link) interned-vectors)) links) (map (lambda (link) (map (lambda (sep) - (explode-named-sig (sig-explode-pair-sigpart sep))) + (explode-named-sig (sig-explode-pair-sigpart sep) interned-vectors)) (link-links link))) links) (flatten-signatures imports) @@ -924,14 +941,16 @@ (link-links link)))) links) (map sig-explode-pair-exploded exports) - (explode-named-sigs imports) + (explode-named-sigs imports interned-vectors) (explode-sig (make-signature 'dummy 'dummy (apply append - (map sig-explode-pair-sigpart exports))))))))))] + (map sig-explode-pair-sigpart exports))) + interned-vectors) + interned-vectors))))))] [_else (raise-syntax-error 'compound-unit/sig "bad syntax" diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 939651a..66a3e3e 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -467,6 +467,7 @@ (let ([constituents (generate-temporaries tags)] [unit-export-positionss (generate-temporaries tags)] [unit-setups (generate-temporaries tags)] + [unit-extracts (generate-temporaries tags)] [unit-export-lists ;; For each tag, get all expected exports (let* ([hts (map (lambda (x) (make-hash-table)) tags)] @@ -519,44 +520,82 @@ (hash-table-put! ht (syntax-e (car l)) p) (loop (cdr l) (add1 p)))) ht)) - unit-export-lists)]) + unit-export-lists)] + [interned-integer-lists null] + [interned-id-lists null]) (let ([make-mapping (lambda (v) (syntax-case v () [(tag . exs) - (let ([ex-poss (map-tag (syntax tag) - unit-export-positionss)] - [setup (map-tag (syntax tag) - unit-setups)] + (let ([extract (map-tag (syntax tag) + unit-extracts)] [ht (map-tag (syntax tag) unit-export-hts)]) - (map - (lambda (e) - (let ([pos (hash-table-get - ht - (syntax-e - (syntax-case e () - [(iid eid) (syntax iid)] - [id e])))]) - (with-syntax ([ex-poss ex-poss] - [setup setup] - [pos (datum->syntax-object - (quote-syntax here) - pos - #f)]) - (syntax - (vector-ref (car setup) - (vector-ref ex-poss pos)))))) - (syntax->list (syntax exs))))] - [import (list v)]))]) - (let ([export-mapping (apply append (map make-mapping exports))] + (with-syntax ([extract extract] + [pos-name + (let ([il + (map + (lambda (e) + (hash-table-get + ht + (syntax-e + (syntax-case e () + [(iid eid) (syntax iid)] + [id e])))) + (syntax->list (syntax exs)))]) + (or (ormap (lambda (i) + (and (equal? il (cadadr i)) + (car i))) + interned-integer-lists) + (let ([name (car (generate-temporaries + (list (syntax tag))))]) + (set! interned-integer-lists + (cons `(,name ',il) + interned-integer-lists)) + name)))]) + (syntax (map extract pos-name))))] + [import v]))] + [collapse (lambda (l) + (let loop ([l l]) + (cond + [(null? l) null] + [(identifier? (car l)) + (let-values ([(ids rest) + (let loop ([l l][ids null]) + (if (or (null? l) + (not (identifier? (car l)))) + (values (reverse ids) l) + (loop (cdr l) (cons (car l) ids))))]) + (let ([name + (let ([id-syms (map syntax-e ids)]) + (or (ormap (lambda (i) + (and (equal? id-syms (cadr i)) + (car i))) + interned-id-lists) + (let ([name + (car (generate-temporaries (list 'ids)))]) + (set! interned-id-lists + (cons (list* name id-syms ids) + interned-id-lists)) + name)))]) + (cons name + (loop rest))))] + [else (cons (car l) (loop (cdr l)))])))]) + (let ([export-mapping (collapse (map make-mapping exports))] [import-mappings (map (lambda (linkage-list) - (apply append - (map make-mapping linkage-list))) + (collapse + (map make-mapping linkage-list))) linkages)]) (with-syntax ([(constituent ...) constituents] [(unit-export-positions ...) unit-export-positionss] [(unit-setup ...) unit-setups] + [(unit-extract ...) unit-extracts] + [interned-integer-lists interned-integer-lists] + [interned-id-lists (map (lambda (i) + (with-syntax ([name (car i)] + [ids (cddr i)]) + (syntax [name (list . ids)]))) + interned-id-lists)] [(unit-export-list ...) unit-export-lists] [(import-mapping ...) import-mappings] [(unit-import-count ...) @@ -596,11 +635,20 @@ (quote export-names) (lambda () (let ([unit-setup ((unit-go constituent))] ...) - (list (vector . export-mapping) - (lambda (ivar ...) - (void) ;; in case there are no units - ((list-ref unit-setup 1) . import-mapping) - ...))))))))))))))))]))) + (let ([unit-extract + (lambda (pos) + (vector-ref (car unit-setup) + (vector-ref unit-export-positions pos)))] + ... + . + interned-integer-lists) + (list (list->vector (append . export-mapping)) + (lambda (ivar ...) + (let interned-id-lists + (void) ;; in case there are no units + (apply (list-ref unit-setup 1) + (append . import-mapping)) + ...))))))))))))))))))]))) (define (check-unit u n) (unless (unit? u) diff --git a/collects/mzlib/unitsig.ss b/collects/mzlib/unitsig.ss index a2eee29..3f9cfea 100644 --- a/collects/mzlib/unitsig.ss +++ b/collects/mzlib/unitsig.ss @@ -16,7 +16,7 @@ (identifier? (syntax name)) (let ([sig (get-sig 'define-signature expr (syntax-e (syntax name)) (syntax sig))]) - (with-syntax ([content (explode-sig sig)]) + (with-syntax ([content (explode-sig sig #f)]) (syntax (define-syntax name (make-sig (quote content))))))]))) @@ -27,7 +27,7 @@ (identifier? (syntax name)) (let ([sig (get-sig 'let-signature expr (syntax-e (syntax name)) (syntax sig))]) - (with-syntax ([content (explode-sig sig)]) + (with-syntax ([content (explode-sig sig #f)]) (syntax (letrec-syntax ([name (make-sig (quote content))]) . body))))]))) @@ -54,8 +54,8 @@ (signature-vars sig)) expr)] [body (reverse! (parse-unit-body a-unit))] - [import-sigs (explode-named-sigs (parse-unit-imports a-unit))] - [export-sig (explode-sig sig)]) + [import-sigs (explode-named-sigs (parse-unit-imports a-unit) #f)] + [export-sig (explode-sig sig #f)]) (syntax (make-unit/sig (unit @@ -77,7 +77,8 @@ link-imports flat-exports exploded-imports - exploded-exports) + exploded-exports + boxed-interned-symbol-vectors) (parse-compound-unit expr (syntax body))] [(t) (lambda (l) (datum->syntax-object expr l expr))]) (with-syntax ([(tag ...) (t tags)] @@ -89,16 +90,17 @@ [(link-import ...) (t link-imports)] [flat-exports (t flat-exports)] [exploded-imports (t exploded-imports)] - [exploded-exports (t exploded-exports)]) + [exploded-exports (t exploded-exports)] + [interned-vectors (t (unbox boxed-interned-symbol-vectors))]) (syntax/loc expr - (let ([tagx uexpr] ...) + (let ([tagx uexpr] ... . interned-vectors) (verify-linkage-signature-match 'compound-unit/sig '(tag ...) (list tagx ...) - 'exploded-link-imports - 'exploded-link-exports) + `exploded-link-imports + `exploded-link-exports) ;; All checks done. Make the unit: (make-unit/sig (compound-unit @@ -107,8 +109,8 @@ . link-import)] ...) (export . flat-exports)) - 'exploded-imports - 'exploded-exports)))))]))) + `exploded-imports + `exploded-exports)))))]))) (define-syntax invoke-unit/sig (lambda (expr) @@ -117,7 +119,7 @@ (let ([sigs (parse-invoke-vars 'invoke-unit/sig (syntax (sig ...)) expr)]) (with-syntax ([exploded-sigs (datum->syntax-object expr - (explode-named-sigs sigs) + (explode-named-sigs sigs #f) expr)] [flat-sigs (datum->syntax-object expr @@ -145,11 +147,11 @@ [ex-sig (get-sig 'unit->unit/sig expr #f (syntax ex-sig))]) (with-syntax ([exploded-imports (datum->syntax-object expr - (explode-named-sigs im-sigs) + (explode-named-sigs im-sigs #f) expr)] [exploded-exports (datum->syntax-object expr - (explode-sig ex-sig) + (explode-sig ex-sig #f) expr)]) (syntax (make-unit/sig @@ -222,7 +224,7 @@ [(_ name) (identifier? (syntax name)) (let ([sig (get-sig 'signature->symbols stx #f (syntax name))]) - (with-syntax ([e (explode-sig sig)]) + (with-syntax ([e (explode-sig sig #f)]) (syntax 'e)))]))) ;; Internal: @@ -243,11 +245,11 @@ (identifier? (syntax prefix))) (badsyntax (syntax prefix) "prefix is not an identifier")) (let ([ex-sig (get-sig formname (syntax orig) #f (syntax signame))]) - (let ([ex-exploded (explode-sig ex-sig)] + (let ([ex-exploded (explode-sig ex-sig #f)] [ex-flattened (flatten-signature #f ex-sig)]) (let ([im-sigs (parse-invoke-vars formname (syntax imports) (syntax orig))]) - (let ([im-explodeds (explode-named-sigs im-sigs)] + (let ([im-explodeds (explode-named-sigs im-sigs #f)] [im-flattened (flatten-signatures im-sigs)] [d->s (lambda (x) (datum->syntax-object (syntax orig) x (syntax orig)))]) (with-syntax ([dv/iu (if (syntax-e (syntax global?))