suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
this shrinks the size of redex/examples/r6rs/r6rs.rkt's .zo file by about 25%
This commit is contained in:
Robby Findler 2012-01-08 10:38:11 -06:00
parent 2afda360d0
commit 4fab7f76af
4 changed files with 112 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/redex/pict.rkt
View File

@ -116,25 +116,9 @@
(require (prefix-in lw/ct: "private/loc-wrapper-ct.rkt") (require (prefix-in lw/ct: "private/loc-wrapper-ct.rkt")
(prefix-in lw/rt: "private/loc-wrapper-rt.rkt")) (prefix-in lw/rt: "private/loc-wrapper-rt.rkt"))
(define (to-lw/stx stx) (define (to-lw/stx stx)
(let loop ([stx (lw/ct:to-lw/proc stx)]) (lw/rt:add-spans/interp-lws
(syntax-case stx (init-loc-wrapper make-lw add-spans list quote) (syntax->datum
[(make-lw arg ...) (lw/ct:to-lw/proc stx #f))))
(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)])))
(provide/contract (provide/contract
[just-before (-> (or/c pict? string? symbol?) lw? lw?)] [just-before (-> (or/c pict? string? symbol?) lw? lw?)]

112
collects/redex/private/loc-wrapper-ct.rkt
View File

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

56
collects/redex/private/loc-wrapper-rt.rkt
View File

@ -1,15 +1,22 @@
#lang scheme/base #lang racket/base
;; this is the runtime code for loc-wrapper-ct.rkt. ;; this is the runtime code for loc-wrapper-ct.rkt.
;; it isn't really its own module, but separated ;; it isn't really its own module, but separated
;; out in order to get the phases right. ;; out in order to get the phases right.
(provide (all-defined-out)) (provide (all-defined-out))
(require mzlib/etc (require racket/match
"term.rkt") "term.rkt")
(define (init-loc-wrapper e line column quoted?) (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) ;; lw = (union 'spring loc-wrapper)
@ -32,6 +39,48 @@
"”") "”")
s)) 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 (add-spans lw)
(define line-seen-so-far 0) (define line-seen-so-far 0)
@ -93,4 +142,3 @@
[b b] [b b]
[else 0])) [else 0]))

2
collects/redex/tests/lw-test.rkt
View File

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