diff --git a/collects/web-server/lang.ss b/collects/web-server/lang.ss index fa939fd3c2..6fd66ca732 100644 --- a/collects/web-server/lang.ss +++ b/collects/web-server/lang.ss @@ -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 + ))))) diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index 827a14e130..c5a3d217a3 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/collects/web-server/lang/abort-resume.ss @@ -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))))))) diff --git a/collects/web-server/lang/defun.ss b/collects/web-server/lang/defun.ss index 3c4127b889..65ec5a2a27 100644 --- a/collects/web-server/lang/defun.ss +++ b/collects/web-server/lang/defun.ss @@ -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" diff --git a/collects/web-server/lang/elim-callcc.ss b/collects/web-server/lang/elim-callcc.ss index 1a9ea1d54f..7958350b7e 100644 --- a/collects/web-server/lang/elim-callcc.ss +++ b/collects/web-server/lang/elim-callcc.ss @@ -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 diff --git a/collects/web-server/lang/elim-letrec.ss b/collects/web-server/lang/elim-letrec.ss index 07d2949e2f..58a2ed5e2b 100644 --- a/collects/web-server/lang/elim-letrec.ss +++ b/collects/web-server/lang/elim-letrec.ss @@ -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 ...) diff --git a/collects/web-server/lang/freevars.ss b/collects/web-server/lang/freevars.ss deleted file mode 100644 index 34b18b3abe..0000000000 --- a/collects/web-server/lang/freevars.ss +++ /dev/null @@ -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))])) diff --git a/collects/web-server/lang/util.ss b/collects/web-server/lang/util.ss index 411bd7d06f..1894034ce7 100644 --- a/collects/web-server/lang/util.ss +++ b/collects/web-server/lang/util.ss @@ -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) diff --git a/collects/web-server/tests/lang-test.ss b/collects/web-server/tests/lang-test.ss index 7d69d314ee..709f20baea 100644 --- a/collects/web-server/tests/lang-test.ss +++ b/collects/web-server/tests/lang-test.ss @@ -565,4 +565,4 @@ (define-values (point i) (values #t 1)) i))))))) - )) + )) \ No newline at end of file