diff --git a/collects/web-server/prototype-web-server/lang.ss b/collects/web-server/prototype-web-server/lang.ss index 4db7466448..134a282f40 100644 --- a/collects/web-server/prototype-web-server/lang.ss +++ b/collects/web-server/prototype-web-server/lang.ss @@ -6,24 +6,17 @@ "lang/elim-letrec.ss" "lang/anormal.ss" "lang/elim-callcc.ss" - "lang/defun.ss" - "lang/mark-lambda.ss") + "lang/defun.ss") (require "lang-api.ss") (provide (rename lang-module-begin #%module-begin)) (provide (all-from "lang-api.ss")) - ; XXX We could optimize this process by marking user-provided lambdas and only defunctionalizing those. - (define-syntax lang-module-begin (make-lang-module-begin make-labeling (make-module-case/new-defs (make-define-case/new-defs (compose #;(lambda (stx) (values stx empty)) - #;(lambda (stx) - (parameterize ([defun? marked-lambda?]) - (defun stx))) defun elim-callcc - (make-anormal-term elim-letrec-term) - #;mark-lambda)))))) \ No newline at end of file + (make-anormal-term elim-letrec-term))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/lang/anormal.ss b/collects/web-server/prototype-web-server/lang/anormal.ss index 9c5fe00365..800b4cab6e 100644 --- a/collects/web-server/prototype-web-server/lang/anormal.ss +++ b/collects/web-server/prototype-web-server/lang/anormal.ss @@ -28,7 +28,7 @@ (define (make-anormal-term elim-letrec-term) (define (anormal-term stx) - (anormal id stx)) + (anormal id stx)) (define (anormal ctxt stx) (recertify diff --git a/collects/web-server/prototype-web-server/lang/defun.ss b/collects/web-server/prototype-web-server/lang/defun.ss index cb12a2a006..cd6e4ad8bf 100644 --- a/collects/web-server/prototype-web-server/lang/defun.ss +++ b/collects/web-server/prototype-web-server/lang/defun.ss @@ -6,15 +6,12 @@ "util.ss" "freevars.ss" "../private/closure.ss") - (provide defun - defun?) + (provide defun) ; make-new-clouse-label : (syntax -> syntax) syntax -> syntax (define (make-new-closure-label labeling stx) (labeling stx)) - (define defun? (make-parameter (lambda _ #t))) - ; defun : syntax[1] -> (values syntax?[2] (listof syntax?)[3]) ; defunctionalizes the first syntax, returning the second and the lifted lambdas [3] (define (defun stx) @@ -64,35 +61,29 @@ [(lambda formals be ...) (let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))]) (with-syntax ([(nbe ...) nbes]) - (if ((defun?) stx) - (let ([fvars (free-vars stx)]) - (let-values ([(make-CLOSURE new-defs) - (make-closure-definition-syntax - (make-new-closure-label (current-code-labeling) stx) - fvars - (syntax/loc stx (lambda formals nbe ...)))]) - (values (if (empty? fvars) - (quasisyntax/loc stx (#,make-CLOSURE)) - (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) - (append be-defs new-defs)))) - (values (quasisyntax/loc stx (lambda formals nbe ...)) - be-defs))))] + (let ([fvars (free-vars stx)]) + (let-values ([(make-CLOSURE new-defs) + (make-closure-definition-syntax + (make-new-closure-label (current-code-labeling) stx) + fvars + (syntax/loc stx (lambda formals nbe ...)))]) + (values (if (empty? fvars) + (quasisyntax/loc stx (#,make-CLOSURE)) + (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) + (append be-defs new-defs))))))] [(case-lambda [formals be ...] ...) (let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))]) (with-syntax ([((nbe ...) ...) nbes]) - (if ((defun?) stx) - (let ([fvars (free-vars stx)]) - (let-values ([(make-CLOSURE new-defs) - (make-closure-definition-syntax - (make-new-closure-label (current-code-labeling) stx) - fvars - (syntax/loc stx (case-lambda [formals nbe ...] ...)))]) - (values (if (empty? fvars) - (quasisyntax/loc stx (#,make-CLOSURE)) - (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) - (append be-defs new-defs)))) - (values (quasisyntax/loc stx (case-lambda [formals nbe ...] ...)) - be-defs))))] + (let ([fvars (free-vars stx)]) + (let-values ([(make-CLOSURE new-defs) + (make-closure-definition-syntax + (make-new-closure-label (current-code-labeling) stx) + fvars + (syntax/loc stx (case-lambda [formals nbe ...] ...)))]) + (values (if (empty? fvars) + (quasisyntax/loc stx (#,make-CLOSURE)) + (quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars))))) + (append be-defs new-defs))))))] [(if te ce ae) (let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))]) (values (quasisyntax/loc stx (if #,@es)) diff --git a/collects/web-server/prototype-web-server/private/web.ss b/collects/web-server/prototype-web-server/private/web.ss index b5e55b4a14..219000e9e1 100644 --- a/collects/web-server/prototype-web-server/private/web.ss +++ b/collects/web-server/prototype-web-server/private/web.ss @@ -54,6 +54,7 @@ (session-url ses) (session-mod-path ses))))))) + ; XXX Changing embedding to be a param (define embed-label 'superkont) (define (embed-proc/url k-url proc) (define ses (current-session))