tweak the compiled representation of lw structs so they take less space

this shrinks the size of redex/examples/r6rs/r6rs.rkt's .zo file by about 25%

collects/redex/pict.rkt

@@ -116,25 +116,9 @@
 (require (prefix-in lw/ct: "private/loc-wrapper-ct.rkt")
          (prefix-in lw/rt: "private/loc-wrapper-rt.rkt"))
 (define (to-lw/stx stx)
-  (let loop ([stx (lw/ct:to-lw/proc stx)])
-    (syntax-case stx (init-loc-wrapper make-lw add-spans list quote)
-      [(make-lw arg ...) 
-       (apply make-lw (map loop (syntax->list #'(arg ...))))]
-      [(init-loc-wrapper arg ...)
-       (apply lw/rt:init-loc-wrapper (map loop (syntax->list #'(arg ...))))]
-      [(add-spans arg ...)
-       (apply lw/rt:add-spans (map loop (syntax->list #'(arg ...))))]
-      [(list arg ...)
-       (apply list (map loop (syntax->list #'(arg ...))))]
-      [(quote arg)
-       (syntax->datum #'arg)]
-      [_ 
-       (let ([x (syntax-e stx)])
-         (unless (or (number? x)
-                     (string? x)
-                     (boolean? x))
-           (error 'to-lw/stx "unk thing: ~s\n" (syntax->datum stx)))
-         x)])))
+  (lw/rt:add-spans/interp-lws 
+   (syntax->datum 
+    (lw/ct:to-lw/proc stx #f))))
 
 (provide/contract
  [just-before (-> (or/c pict? string? symbol?) lw? lw?)]

collects/redex/private/loc-wrapper-ct.rkt

@@ -6,6 +6,7 @@
 
 (define (process-arg stx quote-depth)
   (define quoted? (quote-depth . > . 0))
+  (define init-loc-wrapper/q? (if quoted? 'init-loc-wrapper/quoted 'init-loc-wrapper/unquoted)) 
   (define-values (op cl)
     (if (syntax? stx)
         (case (syntax-property stx 'paren-shape)
@@ -14,79 +15,78 @@
           [else (values "(" ")")])
         (values #f #f)))
   (define (reader-shorthand arg qd-delta mrk)
-    #`(init-loc-wrapper 
-       (list (init-loc-wrapper #,mrk
-                               #,(syntax-line stx)
-                               #,(syntax-column stx)
-                               #,quoted?)
-             'spring
-             #,(process-arg arg (+ quote-depth qd-delta)))
-       #,(syntax-line stx) 
-       #,(syntax-column stx)
-       #,quoted?))
+    #`#(#,init-loc-wrapper/q? 
+        #(list #(#,init-loc-wrapper/q? #,mrk
+                                      #,(syntax-line stx)
+                                      #,(syntax-column stx))
+               'spring
+               #,(process-arg arg (+ quote-depth qd-delta)))
+        #,(syntax-line stx) 
+        #,(syntax-column stx)))
   (define (handle-sequence qd-delta)
-    #`(init-loc-wrapper 
-       (list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
-             #,@(map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))
-             (init-loc-wrapper #,cl #f #f #,quoted?))
-       #,(syntax-line stx) 
-       #,(syntax-column stx)
-       #,quoted?))
+    (with-syntax ([(others ...) (map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))]) 
+      #`#(#,(if quoted?
+                'init-loc-wrapper-sequence/quoted
+                'init-loc-wrapper-sequence/unquoted)
+          #,op #,(syntax-line stx) #,(syntax-column stx)
+          others ...)))
   (syntax-case* stx (name unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
     ['a (reader-shorthand #'a +1 (if (= quote-depth 0) "" "'"))]
     [,a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ","))]
     [,@a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ",@"))]
     [(term a)
      (if (= quote-depth 0)
-         #`(init-loc-wrapper 
-            (list (init-loc-wrapper "" #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
-                  'spring
-                  #,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1)))
-            #,(syntax-line stx) 
-            #,(syntax-column stx)
-            #,quoted?)
+         #`#(#,init-loc-wrapper/q?
+             #(list #(#,init-loc-wrapper/q? "" #,(syntax-line stx) #,(syntax-column stx))
+                    'spring
+                    #,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1)))
+             #,(syntax-line stx) 
+             #,(syntax-column stx))
          (handle-sequence +1))]
     [(a ...)
      (handle-sequence 0)]
     [(a b ... . c)
-     #`(init-loc-wrapper 
-        (list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
-              #,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
-              (init-loc-wrapper #," . " #f #f #,quoted?)
-              #,(process-arg #'c quote-depth)
-              (init-loc-wrapper #,cl #f #f #,quoted?))
-        #,(syntax-line stx) 
-        #,(syntax-column stx)
-        #,quoted?)]
+     #`#(#,init-loc-wrapper/q? 
+         #(list #(#,init-loc-wrapper/q? #,op #,(syntax-line stx) #,(syntax-column stx))
+                #,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
+                #(i,init-loc-wrapper/q? #," . " #f #f)
+                #,(process-arg #'c quote-depth)
+                #(#,init-loc-wrapper/q? #,cl #f #f))
+         #,(syntax-line stx) 
+         #,(syntax-column stx))]
     [x 
      (and (identifier? #'x)
           (and (syntax-transforming?)
                (or (term-fn? (syntax-local-value #'x (λ () #f)))
                    (judgment-form? (syntax-local-value #'x (λ () #f))))))
-     #`(make-lw
-        '#,(syntax-e #'x)
-        #,(syntax-line stx) 
-        #f
-        #,(syntax-column stx)
-        #f
-        #f
-        #t)]
+     #`#(make-lw
+         '#,(syntax-e #'x)
+         #,(syntax-line stx) 
+         #f
+         #,(syntax-column stx)
+         #f
+         #f
+         #t)]
     [x 
      (identifier? #'x)
-     #`(init-loc-wrapper 
-        '#,(syntax-e #'x)
-        #,(syntax-line stx) 
-        #,(syntax-column stx)
-        #,quoted?)]
+     #`#(#,init-loc-wrapper/q? 
+         '#,(syntax-e #'x)
+         #,(syntax-line stx) 
+         #,(syntax-column stx))]
     [x 
-     #`(init-loc-wrapper 
-        #,(let ([base (syntax-e #'x)])
-            (if (string? base)
-                #`(rewrite-quotes #,(format "~s" base))
-                (format "~s" (syntax-e #'x))))
-        #,(syntax-line stx) 
-        #,(syntax-column stx)
-        #,quoted?)]))
+     #`#(#,init-loc-wrapper/q?
+         #,(let ([base (syntax-e #'x)])
+             (if (string? base)
+                 #`#(rewrite-quotes #,(format "~s" base))
+                 (format "~s" (syntax-e #'x))))
+         #,(syntax-line stx) 
+         #,(syntax-column stx))]))
 
-(define (to-lw/proc stx) #`(add-spans #,(process-arg stx 1)))
-(define (to-lw/uq/proc stx) #`(add-spans #,(process-arg stx 0)))
+(define (to-lw/proc stx [add-add-spans? #t]) 
+  (if add-add-spans?
+      #`(add-spans/interp-lws #,(process-arg stx 1))
+      (process-arg stx 1)))
+(define (to-lw/uq/proc stx [add-add-spans? #t])
+  (if add-add-spans?
+      #`(add-spans/interp-lws #,(process-arg stx 0))
+      (process-arg stx 0)))

collects/redex/private/loc-wrapper-rt.rkt

@@ -1,15 +1,22 @@
-#lang scheme/base
+#lang racket/base
 
 ;; this is the runtime code for loc-wrapper-ct.rkt.
 ;; it isn't really its own module, but separated
 ;; out in order to get the phases right.
 (provide (all-defined-out))
 
-(require mzlib/etc
+(require racket/match
          "term.rkt")
 
 (define (init-loc-wrapper e line column quoted?)
-  (make-lw e line #f column #f (not quoted?) #f))
+  (if quoted?
+      (make-lw e line #f column #f #f #f)
+      (make-lw e line #f column #f #t #f)))
+
+(define (init-loc-wrapper/unquoted e line column)
+  (init-loc-wrapper e line column #f))
+(define (init-loc-wrapper/quoted e line column)
+  (init-loc-wrapper e line column #t))
 
 ;; lw = (union 'spring loc-wrapper)
 
@@ -32,6 +39,48 @@
                      "”")
       s))
 
+(define (add-spans/interp-lws arg)
+  (add-spans
+   (let loop ([arg arg])
+     (match arg
+       [(vector 'init-loc-wrapper/quoted e line column)
+        (init-loc-wrapper/quoted (loop e) (loop line) (loop column))]
+       [(vector 'init-loc-wrapper/unquoted e line column)
+        (init-loc-wrapper/unquoted (loop e) (loop line) (loop column))]
+       [(vector 'make-lw e line line-span column column-span unq? metafunction?)
+        (make-lw (loop e) (loop line) (loop line-span) (loop column) 
+                 (loop column-span) (loop unq?) (loop metafunction?))]
+       [(vector 'rewrite-quotes arg)
+        (rewrite-quotes (loop arg))]
+       [(vector 'list x ...)
+        (map loop x)]
+       [(vector (and (or 'init-loc-wrapper-sequence/quoted
+                         'init-loc-wrapper-sequence/unquoted)
+                     kwd)
+                open line col args ...)
+        (define quoted? (eq? 'init-loc-wrapper-sequence/quoted kwd))
+        (define l-line (loop line))
+        (define l-col (loop col))
+        (init-loc-wrapper 
+         (cons (init-loc-wrapper open l-line l-col quoted?)
+               (append (map loop args)
+                       (list (init-loc-wrapper (open->close open) #f #f quoted?))))
+         l-line l-col quoted?)]
+       [`(quote ,x) x]
+       [(? number?) arg]
+       [(? boolean?) arg]
+       [(? string?) arg]
+       [(? symbol?) arg]
+       [else
+        (error 'add-spans/interp-lws "unk ~s" arg)]))))
+
+(define (open->close open)
+  (cond
+    [(equal? open "(") ")"]
+    [(equal? open "[") "]"]
+    [(equal? open "{") "}"]
+    [(equal? open #f) #f]
+    [else (error 'open->close "unk ~s" open)]))
 
 (define (add-spans lw)
   (define line-seen-so-far 0)
@@ -93,4 +142,3 @@
     [b b]
     [else 0]))
 
-

collects/redex/tests/lw-test.rkt

@@ -60,7 +60,7 @@
   (test (normalize-lw (to-lw ()))
         (build-lw (list (build-lw "(" 0 0 0 1)
                         (build-lw ")" 0 0 1 1))
-                           0 0 0 2))
+                  0 0 0 2))
   
   (test (normalize-lw (to-lw "x"))
         (build-lw "“x”" 0 0 0 3))