.

original commit: dbd01b731d1951775207a674ee1ba87c869e3ac0

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"

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)

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?))