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

Removing the hack of freevar.ss in preference for the proper usage of syntax/free-vars. This should also decrease the size of closures, because it is accurate, whereas the other was not.

Browse Source 
svn: r11222
This commit is contained in:
Jay McCarthy 2008-08-13 18:36:51 +00:00
parent 7c6d9bfb58
commit 962fea6513
8 changed files with 74 additions and 185 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/web-server/lang.ss
View File

@ -21,4 +21,7 @@
(compose #;(lambda (stx) (values stx empty))
defun
elim-callcc
(make-anormal-term elim-letrec-term))))))
(make-anormal-term elim-letrec-term)
#;(make-anormal-term (lambda (x) x))
#;elim-letrec-term
)))))

3
collects/web-server/lang/abort-resume.ss
View File

@ -38,7 +38,8 @@
(list* (cons key val)
(filter (lambda (k*v) (not (equal? key (car k*v))))
(let-values ([(current)
(continuation-mark-set->list (current-continuation-marks web-prompt) the-save-cm-key)])
(continuation-mark-set->list (current-continuation-marks web-prompt)
the-save-cm-key)])
(if (empty? current)
empty
(first current)))))))

3
collects/web-server/lang/defun.ss
View File

@ -1,8 +1,7 @@
#lang scheme/base
(require (for-template scheme/base)
syntax/kerncase
#;syntax/free-vars
"freevars.ss"
syntax/free-vars
mzlib/list
mzlib/plt-match
"util.ss"

74
collects/web-server/lang/elim-callcc.ss
View File

@ -77,68 +77,74 @@
(#%plain-app current-saved-continuation-marks-and #,ke-prime #,me-prime)
#,be-prime)))))]
[(#%plain-app call/cc w)
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks)]
[(x ref-to-x) (generate-formal 'x)])
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks stx)]
[(x ref-to-x) (generate-formal 'x stx)])
(markit
(quasisyntax/loc stx
(#%plain-app #,(elim-callcc #'w)
(#%plain-app (#%plain-lambda (#,cm)
(#%plain-lambda #,x
(#%plain-app abort
(#%plain-lambda () (#%plain-app resume #,ref-to-cm #,ref-to-x)))))
(#%plain-app activation-record-list))))))]
(#%plain-app
#,(elim-callcc #'w)
(#%plain-app
(#%plain-lambda
(#,cm)
(#%plain-lambda #,x
(#%plain-app abort
(#%plain-lambda () (#%plain-app resume #,ref-to-cm #,ref-to-x)))))
(#%plain-app activation-record-list))))))]
[(#%plain-app call-with-values (#%plain-lambda () prod) cons)
(let ([cons-prime (datum->syntax #f (gensym 'cons))])
(let-values ([(consumer ref-to-consumer) (generate-formal 'consumer stx)])
(quasisyntax/loc stx
(let-values ([(#,cons-prime) #,(mark-lambda-as-safe (elim-callcc #'cons))])
(let-values ([(#,consumer) #,(mark-lambda-as-safe (elim-callcc #'cons))])
#,(markit
(quasisyntax/loc stx
(#%plain-app call-with-values
#,(mark-lambda-as-safe
(quasisyntax/loc stx
(#%plain-lambda ()
#,(elim-callcc/mark
(lambda (x)
(quasisyntax/loc stx
(with-continuation-mark the-cont-key #,cons-prime #,x)))
#'prod))))
#,cons-prime))))))]
(#%plain-app
call-with-values
#,(mark-lambda-as-safe
(quasisyntax/loc stx
(#%plain-lambda ()
#,(elim-callcc/mark
(lambda (x)
(quasisyntax/loc stx
(with-continuation-mark the-cont-key #,ref-to-consumer #,x)))
#'prod))))
#,ref-to-consumer))))))]
[(#%plain-app w (#%plain-app . stuff))
(with-syntax ([e #'(#%plain-app . stuff)])
(syntax-case #'w (#%plain-lambda case-lambda)
[(#%plain-lambda formals body)
(let ([w-prime (datum->syntax #f (gensym 'l))])
(let-values ([(w-prime ref-to-w-prime) (generate-formal 'l stx)])
(quasisyntax/loc stx
(let-values ([(#,w-prime) #,(elim-callcc #'w)])
#,(markit
(quasisyntax/loc stx
(#%plain-app #,w-prime
(#%plain-app #,ref-to-w-prime
#,(elim-callcc/mark
(lambda (x)
(quasisyntax/loc stx
(with-continuation-mark the-cont-key #,w-prime #,x)))
(with-continuation-mark the-cont-key #,ref-to-w-prime #,x)))
#'e)))))))]
[(case-lambda [formals body] ...)
(let ([w-prime (datum->syntax #f (gensym 'cl))])
(let-values ([(w-prime ref-to-w-prime) (generate-formal 'cl stx)])
(quasisyntax/loc stx
(let-values ([(#,w-prime) #,(elim-callcc #'w)])
#,(markit
(quasisyntax/loc stx
(#%plain-app #,w-prime
(#%plain-app #,ref-to-w-prime
#,(elim-callcc/mark
(lambda (x)
(quasisyntax/loc stx
(with-continuation-mark the-cont-key #,w-prime #,x)))
(with-continuation-mark the-cont-key #,ref-to-w-prime #,x)))
#'e)))))))]
[_else
(let ([w-prime (elim-callcc #'w)])
(markit
(quasisyntax/loc stx
(#%plain-app #,w-prime
#,(elim-callcc/mark
(lambda (x)
#`(with-continuation-mark the-cont-key #,w-prime #,x))
#'e)))))]))]
(let-values ([(w-prime ref-to-w-prime) (generate-formal 'other stx)])
(quasisyntax/loc stx
(let ([#,w-prime #,(elim-callcc #'w)])
(markit
(quasisyntax/loc stx
(#%plain-app #,ref-to-w-prime
#,(elim-callcc/mark
(lambda (x)
#`(with-continuation-mark the-cont-key #,ref-to-w-prime #,x))
#'e)))))))]))]
[(#%plain-app w rest ...)
(markit
(quasisyntax/loc stx

32
collects/web-server/lang/elim-letrec.ss
View File

@ -34,22 +34,32 @@
(syntax/loc stx
(let-values ([(v ...) ve] ...) be ...)))]
[(letrec-values ([(v ...) ve] ...) be ...)
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((v ...) ...))))])
(with-syntax ([((nv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((v ...) ...)))]
[((nv-box ...) ...) (map (lambda (nvs)
(map (lambda (x) (syntax/loc x (#%plain-app box the-undef)))
(syntax->list nvs)))
(syntax->list #`((v ...) ...)))]
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
; XXX Optimize special case of one nv
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((v ...) ...))))]
[gfss (map (lambda (vs)
(map (lambda (v)
(define-values (v-def v-ref) (generate-formal (syntax->datum v) v))
(cons v-def v-ref))
(syntax->list vs)))
(syntax->list #'((v ...) ...)))])
(with-syntax
([((nv-def ...) ...)
(map (lambda (gfs) (map car gfs)) gfss)]
[((nv-ref ...) ...)
(map (lambda (gfs) (map cdr gfs)) gfss)]
[((nv-box ...) ...) (map (lambda (nvs)
(map (lambda (x) (syntax/loc x (#%plain-app box the-undef)))
(syntax->list nvs)))
(syntax->list #`((v ...) ...)))]
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
(syntax/loc stx
(let-values ([(v ...)
(#%plain-app values nv-box ...)] ...)
(begin (#%plain-app call-with-values
(#%plain-lambda () ve)
(#%plain-lambda (nv ...)
(#%plain-app set-box! v nv) ...))
(#%plain-lambda
(nv-def ...)
(#%plain-app set-box! v nv-ref) ...))
...
be ...)))))]
[(#%plain-lambda formals be ...)

130
collects/web-server/lang/freevars.ss
View File

@ -1,130 +0,0 @@
#lang scheme/base
(require (for-template scheme/base)
syntax/kerncase
mzlib/list
syntax/toplevel
mzlib/plt-match
syntax/stx
"util.ss")
(provide free-vars)
;; free-vars: syntax -> (listof identifier)
;; Find the free variables in an expression
(define (free-vars stx)
(kernel-syntax-case
stx (transformer?)
[(begin be ...)
(free-vars* (syntax->list #'(be ...)))]
[(begin0 be ...)
(free-vars* (syntax->list #'(be ...)))]
[(set! v ve)
(union (free-vars #'v)
(free-vars #'ve))]
[(let-values ([(v ...) ve] ...) be ...)
(union (free-vars* (syntax->list #'(ve ...)))
(set-diff (free-vars* (syntax->list #'(be ...)))
(apply append (map syntax->list (syntax->list #'((v ...) ...))))))]
[(letrec-values ([(v ...) ve] ...) be ...)
(set-diff (union (free-vars* (syntax->list #'(ve ...)))
(free-vars* (syntax->list #'(be ...))))
(apply append (map syntax->list (syntax->list #'((v ...) ...)))))]
[(#%plain-lambda formals be ...)
(set-diff (free-vars* (syntax->list #'(be ...)))
(formals-list #'formals))]
[(case-lambda [formals be ...] ...)
(apply union*
(map (lambda (fs bes)
(set-diff (free-vars* (syntax->list bes))
(formals-list fs)))
(syntax->list #'(formals ...))
(syntax->list #'((be ...) ...))))]
[(if te ce ae)
(free-vars* (syntax->list #'(te ce ae)))]
[(quote datum)
empty]
[(quote-syntax datum)
empty]
[(with-continuation-mark ke me be)
(free-vars* (syntax->list #'(ke me be)))]
[(#%plain-app e ...)
(free-vars* (syntax->list #'(e ...)))]
[(#%top . v)
#;(printf "Not including top ~S in freevars~n" (syntax->datum #'v))
empty]
[(#%variable-reference . id)
(let ([i-bdg (identifier-binding #'id)])
(cond
[(eqv? 'lexical i-bdg)
(list #'id)]
[(not i-bdg)
(list #'id)]
[else
#;(printf "Not including var-reference ~S with binding ~S in freevars~n" (syntax->datum #'id) i-bdg)
empty]))]
[id (identifier? #'id)
(let ([i-bdg (identifier-binding #'id)])
#;(printf "ID ~S with binding ~S in freevars~n" (syntax->datum #'id) i-bdg)
(cond
[(eqv? 'lexical i-bdg)
(list #'id)]
[(not i-bdg)
(list #'id)]
[else
#;(printf "Not including id ~S with binding ~S in freevars~n" (syntax->datum #'id) i-bdg)
empty]))]
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(free-vars #'(letrec-values ([(vv ...) ve] ...) be ...))]
[(#%expression d)
(free-vars #'d)]
[_
(raise-syntax-error 'freevars "Dropped through:" stx)]))
;; free-vars*: (listof expr) -> (listof identifier)
;; union the free variables that occur in several expressions
(define (free-vars* exprs)
(foldl
(lambda (expr acc) (union (free-vars expr) acc))
empty exprs))
;; union: (listof identifier) (listof identifier) -> (listof identifier)
;; produce the set-theoretic union of two lists
(define (union l1 l2)
(cond
[(null? l1) l2]
[else (insert (car l1) (union (cdr l1) l2))]))
(define (union* . ll)
(foldl union
empty
ll))
;; insert: symbol (listof identifier) -> (listof symbol)
;; insert a symbol into a list without creating a duplicate
(define (insert sym into)
(unless (identifier? sym)
(raise-syntax-error 'insert "Not identifier" sym))
(cond
[(null? into) (list sym)]
[(free-identifier=? sym (car into)) into]
[else (cons (car into) (insert sym (cdr into)))]))
;; set-diff: (listof identifier) (listof identifier) -> (listof identifier)
;; produce the set-theoretic difference of two lists
(define (set-diff s1 s2)
(cond
[(null? s2) s1]
[else (set-diff (sans s1 (car s2)) (cdr s2))]))
;; sans: (listof identifier) symbol -> (listof identifier)
;; produce the list sans the symbol
(define (sans s elt)
(unless (identifier? elt)
(raise-syntax-error 'sans "Not identifier" elt))
(cond
[(null? s) empty]
[(free-identifier=? (car s) elt)
(cdr s)] ;; if we maintain the no-dupe invariant then we don't need to recur
[else (cons (car s)
(sans (cdr s) elt))]))

10
collects/web-server/lang/util.ss
View File

@ -27,12 +27,12 @@
(lambda (stx)
(datum->syntax stx 'error))))
(define (generate-formal sym-name)
(let ([name (datum->syntax #f (gensym sym-name))])
(with-syntax ([(lambda (formal) ref-to-formal)
(define (generate-formal sym-name [stx-base #f])
(let ([name (datum->syntax stx-base (gensym sym-name))])
(with-syntax ([(#%plain-lambda (formal) ref-to-formal)
(if (syntax-transforming?)
(local-expand #`(lambda (#,name) #,name) 'expression empty)
#`(lambda (#,name) #,name))])
(local-expand #`(#%plain-lambda (#,name) #,name) 'expression empty)
#`(#%plain-lambda (#,name) #,name))])
(values #'formal #'ref-to-formal))))
(define (formals-list stx)

2
collects/web-server/tests/lang-test.ss
View File

@ -565,4 +565,4 @@
(define-values (point i) (values #t 1))
i)))))))
))
))