From 22384487e8b326c1a1488edcaf6d133fb4963b7b Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 23 Jun 2009 16:09:22 +0000 Subject: [PATCH] Adding serial-lambda and changing how defun works svn: r15243 --- collects/web-server/lang.ss | 8 +- collects/web-server/lang/closure.ss | 118 ++++++++++++ collects/web-server/lang/defun.ss | 180 +++++++----------- collects/web-server/lang/serial-lambda.ss | 29 +++ collects/web-server/lang/util.ss | 54 ++---- collects/web-server/lang/web-cells.ss | 2 +- collects/web-server/lang/web-param.ss | 6 +- collects/web-server/private/closure.ss | 129 ------------- collects/web-server/private/define-closure.ss | 26 ++- collects/web-server/scribblings/closure.scrbl | 44 ++--- 10 files changed, 281 insertions(+), 315 deletions(-) create mode 100644 collects/web-server/lang/closure.ss create mode 100644 collects/web-server/lang/serial-lambda.ss delete mode 100644 collects/web-server/private/closure.ss diff --git a/collects/web-server/lang.ss b/collects/web-server/lang.ss index 1ba70de28f..04b1d60029 100644 --- a/collects/web-server/lang.ss +++ b/collects/web-server/lang.ss @@ -18,10 +18,10 @@ (define-syntax lang-module-begin (make-lang-module-begin make-labeling - (make-module-case/new-defs - (make-define-case/new-defs + (make-module-case + (make-define-case (lambda (stx) (define anf-stx (anormalize stx)) (define no-callcc-stx (elim-callcc anf-stx)) - (define-values (defun-stx new-defs) (defun no-callcc-stx)) - (values defun-stx new-defs)))))) + (define defun-stx (defun no-callcc-stx)) + defun-stx))))) diff --git a/collects/web-server/lang/closure.ss b/collects/web-server/lang/closure.ss new file mode 100644 index 0000000000..c6ee1f25ed --- /dev/null +++ b/collects/web-server/lang/closure.ss @@ -0,0 +1,118 @@ +#lang scheme +(require syntax/free-vars + (for-template + scheme/base + scheme/serialize)) + +(define (define-closure! label fvars stx) + ; Boxes + (define make-CLOSURE-box + (syntax-local-lift-expression + (quasisyntax/loc stx + (box (lambda (env) (error 'make-CLOSURE "Closure<~e> not initialized" '#,label)))))) + (define CLOSURE-set-env!-box + (syntax-local-lift-expression + (quasisyntax/loc stx + (box (lambda (clsr new-env) (error 'CLOSURE-set-env! "Closure<~e> not initialized" '#,label)))))) + (define CLOSURE-env-box + (syntax-local-lift-expression + (quasisyntax/loc stx + (box (lambda (clsr) (error 'CLOSURE-env "Closure<~e> not initialized" '#,label)))))) + ; Define the deserializer (req closure struct values under lambdas) + (define CLOSURE:deserialize-info-id + (syntax-local-lift-expression + (quasisyntax/loc stx + (make-deserialize-info + + ;; make-proc: value ... -> CLOSURE + (lambda args + (apply (#%plain-lambda #,fvars + ((unbox #,make-CLOSURE-box) (#%plain-lambda () (values #,@fvars)))) + args)) + + ;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void)) + (lambda () + (let ([new-closure + ((unbox #,make-CLOSURE-box) + (#%plain-lambda () (error 'deserialize "closure not initialized")))]) + (values + new-closure + (#%plain-lambda (clsr) + ((unbox #,CLOSURE-set-env!-box) new-closure ((unbox #,CLOSURE-env-box) clsr)))))))))) + ; Define the serializer (req closure struct values + deserializer identifier) + (define CLOSURE:serialize-info-id + (syntax-local-lift-expression + (quasisyntax/loc stx + (make-serialize-info + + ;; to-vector: CLOSURE -> vector + (#%plain-lambda (clsr) + (#%plain-app call-with-values + (#%plain-lambda () (((unbox #,CLOSURE-env-box) clsr))) + vector)) + + ;; The serializer id: -------------------- + (quote-syntax #,CLOSURE:deserialize-info-id) + + ;; can-cycle? + #t + + ;; Directory for last-ditch resolution -------------------- + (or (current-load-relative-directory) (current-directory)))))) + ; Define the closure struct (req serialize info value) + (define-values + (make-CLOSURE-id CLOSURE?-id CLOSURE-env-id CLOSURE-set-env!-id) + (apply + values + (syntax-local-lift-values-expression + 4 + (quasisyntax/loc stx + (letrec-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!) + (make-struct-type + '#,label ;; the tag goes here + #f ; no super type + 1 + 0 ; number of auto-fields + #f ; auto-v + + ; prop-vals: + (list (cons prop:serializable #,CLOSURE:serialize-info-id) + (cons prop:procedure + (#%plain-lambda (clsr . args) + (let-values ([#,fvars ((CLOSURE-ref clsr 0))]) + (apply #,stx args))))) + + #f ; inspector + + ;; the struct apply proc: + #f)] + [(CLOSURE-env) + (#%plain-lambda (clsr) (CLOSURE-ref clsr 0))] + [(CLOSURE-set-env!) + (#%plain-lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env))]) + (set-box! #,CLOSURE-env-box CLOSURE-env) + (set-box! #,CLOSURE-set-env!-box CLOSURE-set-env!) + (set-box! #,make-CLOSURE-box make-CLOSURE) + (values make-CLOSURE CLOSURE? CLOSURE-env CLOSURE-set-env!)))))) + ; Provide the deserializer (req deserializer identifier) + (syntax-local-lift-provide + (quasisyntax/loc stx + #,CLOSURE:deserialize-info-id)) + (values make-CLOSURE-id CLOSURE?-id CLOSURE-env-id)) + +(define (make-closure stx) + (syntax-case stx () + [(_ label lambda-stx) + (let*-values + ([(lambda-fe-stx) (local-expand #'lambda-stx 'expression empty)] + [(fvars) (free-vars lambda-fe-stx)] + ; Define the closure struct (req serialize info value) + [(make-CLOSURE-id CLOSURE?-id CLOSURE-env-id) + (define-closure! #'label fvars lambda-fe-stx)]) + ; Instantiate the closure + (quasisyntax/loc stx + (#,make-CLOSURE-id (#%plain-lambda () (values #,@fvars)))))])) + +(provide + make-closure + define-closure!) \ No newline at end of file diff --git a/collects/web-server/lang/defun.ss b/collects/web-server/lang/defun.ss index da54fe69c4..c557da50b5 100644 --- a/collects/web-server/lang/defun.ss +++ b/collects/web-server/lang/defun.ss @@ -1,14 +1,12 @@ #lang scheme/base (require (for-template scheme/base) syntax/kerncase - syntax/free-vars scheme/contract - mzlib/list - mzlib/plt-match - "util.ss" - "../private/closure.ss") + web-server/lang/closure + (for-template web-server/lang/serial-lambda) + "util.ss") (provide/contract - [defun (syntax? . -> . (values syntax? (listof syntax?)))]) + [defun (syntax? . -> . syntax?)]) ; make-new-clouse-label : (syntax -> syntax) syntax -> syntax (define (make-new-closure-label labeling stx) @@ -17,111 +15,79 @@ ; defun : syntax[1] -> (values syntax?[2] (listof syntax?)[3]) ; defunctionalizes the first syntax, returning the second and the lifted lambdas [3] (define (defun stx) - (recertify/new-defs + (recertify stx - (lambda () - (kernel-syntax-case - stx (transformer?) - [(begin be ...) - (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))]) - (values (quasisyntax/loc stx (begin #,@nbes)) - defs))] - [(begin0 be ...) - (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))]) - (values (quasisyntax/loc stx (begin0 #,@nbes)) - defs))] - [(set! v ve) - (let-values ([(nve defs) (defun #'ve)]) - (values (quasisyntax/loc stx (set! v #,nve)) - defs))] - [(let-values ([(v ...) ve] ...) be ...) - (let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))] - [(nbes be-defs) (defun* (syntax->list #'(be ...)))]) - (with-syntax ([(nve ...) nves] - [(nbe ...) nbes]) - (values (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...)) - (append ve-defs be-defs))))] - [(letrec-values ([(v ...) ve] ...) be ...) - (let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))] - [(nbes be-defs) (defun* (syntax->list #'(be ...)))]) - (with-syntax ([(nve ...) nves] - [(nbe ...) nbes]) - (values (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...)) - (append ve-defs be-defs))))] - [(#%plain-lambda formals be ...) - (let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))]) - (with-syntax ([(nbe ...) nbes]) - (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 (#%plain-lambda formals nbe ...)))]) - (values (if (empty? fvars) - (quasisyntax/loc stx (#,make-CLOSURE)) - (quasisyntax/loc stx (#,make-CLOSURE (#%plain-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]) - (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)) - defs))] - [(quote datum) - (values stx - empty)] - [(quote-syntax datum) - (values stx - empty)] - [(with-continuation-mark ke me be) - (let-values ([(es defs) (defun* (list #'ke #'me #'be))]) - (values (quasisyntax/loc stx (with-continuation-mark #,@es)) - defs))] - [(#%plain-app e ...) - (let-values ([(es defs) (defun* (syntax->list #'(e ...)))]) - (values (quasisyntax/loc stx (#%plain-app #,@es)) - defs))] - [(#%top . v) - (values stx - empty)] - [(#%variable-reference . v) - (values stx - empty)] - [id (identifier? #'id) - (values stx - empty)] - [(#%expression d) - (let-values ([(nd d-defs) (defun #'d)]) - (values (quasisyntax/loc stx (#%expression #,nd)) - d-defs))] - [_ - (raise-syntax-error 'defun "Dropped through:" stx)])))) + (kernel-syntax-case + stx (transformer?) + [(begin be ...) + (let-values ([(nbes) (defun* (syntax->list #'(be ...)))]) + (quasisyntax/loc stx (begin #,@nbes)))] + [(begin0 be ...) + (let-values ([(nbes) (defun* (syntax->list #'(be ...)))]) + (quasisyntax/loc stx (begin0 #,@nbes)))] + [(set! v ve) + (let-values ([(nve) (defun #'ve)]) + (quasisyntax/loc stx (set! v #,nve)))] + [(let-values ([(v ...) ve] ...) be ...) + (let-values ([(nves) (defun* (syntax->list #'(ve ...)))] + [(nbes) (defun* (syntax->list #'(be ...)))]) + (with-syntax ([(nve ...) nves] + [(nbe ...) nbes]) + (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...))))] + [(letrec-values ([(v ...) ve] ...) be ...) + (let-values ([(nves) (defun* (syntax->list #'(ve ...)))] + [(nbes) (defun* (syntax->list #'(be ...)))]) + (with-syntax ([(nve ...) nves] + [(nbe ...) nbes]) + (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...))))] + [(#%plain-lambda formals be ...) + (let-values ([(nbes) (defun* (syntax->list #'(be ...)))]) + (with-syntax ([(nbe ...) nbes]) + (syntax/loc stx + (serial-lambda formals nbe ...)) + #; + (make-closure + (quasisyntax/loc stx + (_ #,(make-new-closure-label (current-code-labeling) stx) (#%plain-lambda formals nbe ...))))))] + [(case-lambda [formals be ...] ...) + (let-values ([(nbes) (defun** (syntax->list #'((be ...) ...)))]) + (with-syntax ([((nbe ...) ...) nbes]) + (syntax/loc stx + (serial-case-lambda + [formals nbe ...] + ...)) + #; + (make-closure + (quasisyntax/loc stx + (_ #,(make-new-closure-label (current-code-labeling) stx) (case-lambda [formals nbe ...] ...))))))] + [(if te ce ae) + (let-values ([(es) (defun* (syntax->list #'(te ce ae)))]) + (quasisyntax/loc stx (if #,@es)))] + [(quote datum) + stx] + [(quote-syntax datum) + stx] + [(with-continuation-mark ke me be) + (let-values ([(es) (defun* (list #'ke #'me #'be))]) + (quasisyntax/loc stx (with-continuation-mark #,@es)))] + [(#%plain-app e ...) + (let-values ([(es) (defun* (syntax->list #'(e ...)))]) + (quasisyntax/loc stx (#%plain-app #,@es)))] + [(#%top . v) + stx] + [(#%variable-reference . v) + stx] + [id (identifier? #'id) + stx] + [(#%expression d) + (let-values ([(nd) (defun #'d)]) + (quasisyntax/loc stx (#%expression #,nd)))] + [_ + (raise-syntax-error 'defun "Dropped through:" stx)]))) ; lift defun to list of syntaxes (define (lift-defun defun) (lambda (stxs) - (match - (foldl (lambda (stx acc) - (let-values ([(nstx stx-defs) (defun stx)]) - (match acc - [(list-rest nstxs defs) - (cons (list* nstx nstxs) - (append stx-defs defs))]))) - (cons empty empty) - stxs) - [(list-rest nstxs defs) - (values (reverse nstxs) - defs)]))) + (map defun stxs))) (define defun* (lift-defun defun)) (define defun** (lift-defun (lambda (stx) (defun* (syntax->list stx))))) diff --git a/collects/web-server/lang/serial-lambda.ss b/collects/web-server/lang/serial-lambda.ss new file mode 100644 index 0000000000..cda72ff2f3 --- /dev/null +++ b/collects/web-server/lang/serial-lambda.ss @@ -0,0 +1,29 @@ +#lang scheme +(require scheme/serialize + (for-syntax scheme + web-server/lang/closure + web-server/lang/labels)) + +(define-syntax (serial-lambda stx) + (syntax-case stx () + [(_ . lmbda-stx) + (let ([labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax->datum stx))))]) + (make-closure + (quasisyntax/loc stx + (_ #,(labeling) (lambda . lmbda-stx)))))])) + +(define-syntax (serial-case-lambda stx) + (syntax-case stx () + [(_ . lmbda-stx) + (let ([labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax->datum stx))))]) + (make-closure + (quasisyntax/loc stx + (_ #,(labeling) (case-lambda . lmbda-stx)))))])) + +(provide serial-lambda + serial-case-lambda) + +(provide/contract + [closure->deserialize-name (serializable? . -> . symbol?)]) +(define (closure->deserialize-name proc) + (string->symbol (cdr (first (third (serialize proc)))))) \ No newline at end of file diff --git a/collects/web-server/lang/util.ss b/collects/web-server/lang/util.ss index af3afa7803..abcc864c66 100644 --- a/collects/web-server/lang/util.ss +++ b/collects/web-server/lang/util.ss @@ -1,20 +1,16 @@ #lang scheme/base (require (for-template scheme/base) - scheme/pretty scheme/list - scheme/contract - syntax/kerncase) + scheme/contract) (provide/contract [transformer? (parameter/c boolean?)] [recertify (syntax? syntax? . -> . syntax?)] - [recertify* (syntax? (listof syntax?) . -> . (listof syntax?))] - [recertify/new-defs (syntax? (-> (values syntax? (listof syntax?))) . -> . (values syntax? (listof syntax?)))] [current-code-labeling (parameter/c (syntax? . -> . syntax?))] [generate-formal ((symbol?) ((or/c false/c syntax?)) . ->* . (values syntax? syntax?))] [formals-list (syntax? . -> . (listof syntax?))] - [make-define-case/new-defs ((syntax? . -> . (values syntax? (listof syntax?))) . -> . (syntax? . -> . (listof syntax?)))] - [make-module-case/new-defs ((syntax? . -> . (listof syntax?)) . -> . (syntax? . -> . (listof syntax?)))] - [make-lang-module-begin ((bytes? . -> . (-> symbol?)) (syntax? . -> . (listof syntax?)) . -> . (syntax? . -> . syntax?))] + [make-define-case ((syntax? . -> . syntax?) . -> . (syntax? . -> . syntax?))] + [make-module-case ((syntax? . -> . syntax?) . -> . (syntax? . -> . syntax?))] + [make-lang-module-begin ((bytes? . -> . (-> symbol?)) (syntax? . -> . syntax?) . -> . (syntax? . -> . syntax?))] [bound-identifier-member? (syntax? (listof syntax?) . -> . boolean?)]) (define transformer? (make-parameter #f)) @@ -22,18 +18,6 @@ (define (recertify old-expr expr) (syntax-recertify expr old-expr (current-code-inspector) #f)) -(define (recertify* old-expr exprs) - (map (lambda (expr) - (syntax-recertify expr old-expr (current-code-inspector) #f)) - exprs)) - -(define (recertify/new-defs old-expr thunk) - (call-with-values - thunk - (lambda (expr new-defs) - (values (recertify old-expr expr) - (recertify* old-expr new-defs))))) - (define current-code-labeling (make-parameter (lambda (stx) @@ -56,32 +40,29 @@ [(v ... . rv) (list* #'rv (syntax->list #'(v ...)))])) -(define ((make-define-case/new-defs inner) stx) - (recertify* +(define ((make-define-case inner) stx) + (recertify stx (syntax-case stx (define-values define-syntaxes define-values-for-syntax) [(define-values (v ...) ve) - (let-values ([(nve defs) (inner #'ve)]) - (append - defs - (list (quasisyntax/loc stx - (define-values (v ...) #,nve)))))] + (let-values ([(nve) (inner #'ve)]) + (quasisyntax/loc stx + (define-values (v ...) #,nve)))] [(define-syntaxes (v ...) ve) - (list stx)] + stx] [(define-values-for-syntax (v ...) ve) - (list stx)] + stx] [(#%require spec ...) - (list stx)] + stx] [expr - (let-values ([(nexpr defs) (inner #'expr)]) - (append defs (list nexpr)))]))) + (inner #'expr)]))) -(define ((make-module-case/new-defs inner) stx) - (recertify* +(define ((make-module-case inner) stx) + (recertify stx (syntax-case* stx (#%provide) free-identifier=? [(#%provide spec ...) - (list stx)] + stx] [_ (inner stx)]))) @@ -99,8 +80,7 @@ (define new-defs (parameterize ([current-code-labeling (lambda (stx) (datum->syntax stx (base-labeling)))]) - (apply append (map transform (syntax->list #'(body ...)))))) - #;(pretty-print (syntax->datum #`(pmb #,@new-defs))) + (map transform (syntax->list #'(body ...))))) (quasisyntax/loc stx (pmb #,@new-defs)))]))) diff --git a/collects/web-server/lang/web-cells.ss b/collects/web-server/lang/web-cells.ss index 221ad30c2c..d714f3012d 100644 --- a/collects/web-server/lang/web-cells.ss +++ b/collects/web-server/lang/web-cells.ss @@ -1,6 +1,6 @@ #lang scheme (require scheme/serialize - "../private/closure.ss") + web-server/lang/serial-lambda) ;; Implementation: Have a distinguished frame variable that is read and captured by send/suspend, ;; installed on invocations of continuations by the server (and NOT from other continuation invocations) diff --git a/collects/web-server/lang/web-param.ss b/collects/web-server/lang/web-param.ss index 73b6ec122f..3fa759ec01 100644 --- a/collects/web-server/lang/web-param.ss +++ b/collects/web-server/lang/web-param.ss @@ -1,7 +1,7 @@ #lang scheme/base (require (for-syntax scheme/base) scheme/contract - "../private/closure.ss" + web-server/lang/serial-lambda mzlib/list) (provide/contract @@ -11,8 +11,8 @@ (define (web-parameter? any) (and (procedure? any) - (procedure-arity-includes? any 0) - (procedure-arity-includes? any 2))) + (procedure-arity-includes? any 0) + (procedure-arity-includes? any 2))) (define next-web-parameter-id (let ([i (box 0)]) diff --git a/collects/web-server/private/closure.ss b/collects/web-server/private/closure.ss deleted file mode 100644 index 0dcab53a52..0000000000 --- a/collects/web-server/private/closure.ss +++ /dev/null @@ -1,129 +0,0 @@ -#lang scheme/base -(require (for-template scheme/base) - (for-template mzlib/serialize) - mzlib/list - scheme/contract - mzlib/serialize) -(provide/contract - [closure->deserialize-name (serializable? . -> . symbol?)]) -(provide make-closure-definition-syntax) - -(define (closure->deserialize-name proc) - (cdr (first (third (serialize proc))))) - -(define (make-closure-definition-syntax tag fvars proc) - (define (make-id str) - (datum->syntax tag (string->symbol (format str (syntax->datum tag))))) - (with-syntax ([CLOSURE:deserialize-info (make-id "~a:deserialize-info")] - [CLOSURE:serialize-info (make-id "~a:serialize-info")] - [make-CLOSURE (make-id "make-~a")] - [CLOSURE? (make-id "~a?")] - [CLOSURE-ref (make-id "~a-ref")] - [CLOSURE-set! (make-id "~a-set!")] - [CLOSURE-env (make-id "~a-env")] - [set-CLOSURE-env! (make-id "set-~a-env!")] - [struct:CLOSURE (make-id "struct:~a")]) - (values - (syntax/loc proc make-CLOSURE) - (list - (quasisyntax/loc proc - (define CLOSURE:deserialize-info - (make-deserialize-info - - ;; make-proc: value ... -> CLOSURE - (lambda args - (apply #,(if (null? fvars) - (syntax/loc proc - (#%plain-lambda () (#%plain-app make-CLOSURE))) - (quasisyntax/loc proc - (#%plain-lambda #,fvars - (#%plain-app make-CLOSURE - (#%plain-lambda () - (#%plain-app values #,@fvars)))))) - args)) - - ;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void)) - (lambda () - (let ([new-closure - #,(if (null? fvars) - (syntax/loc proc (#%plain-app make-CLOSURE)) - (syntax/loc proc - (#%plain-app make-CLOSURE - (#%plain-lambda () (#%plain-app error "closure not initialized")))))]) - (values - new-closure - #,(if (null? fvars) - (syntax/loc proc void) - (syntax/loc proc - (#%plain-lambda (clsr) - (#%plain-app set-CLOSURE-env! new-closure (#%plain-app CLOSURE-env clsr))))))))))) - - (quasisyntax/loc proc - (provide CLOSURE:deserialize-info)) - - (quasisyntax/loc proc - (define CLOSURE:serialize-info - (make-serialize-info - - ;; to-vector: CLOSURE -> vector - #,(if (null? fvars) - (syntax/loc proc (#%plain-lambda (clsr) (#%plain-app vector))) - (syntax/loc proc - (#%plain-lambda (clsr) - (#%plain-app call-with-values - (#%plain-lambda () (#%plain-app (#%plain-app CLOSURE-env clsr))) - vector)))) - - ;; The serializer id: -------------------- - ;(syntax deserialize-info:CLOSURE) - ;; I still don't know what to put here. - ;; oh well. - ;(quote-syntax #,(syntax deserialize-info:CLOSURE)) - (let ([b (identifier-binding (quote-syntax CLOSURE:deserialize-info))]) - (if (list? b) - (cons 'CLOSURE:deserialize-info (caddr b)) - 'CLOSURE:deserialize-info)) - - ;; can-cycle? - #t - - ;; Directory for last-ditch resolution -------------------- - (or (current-load-relative-directory) (current-directory)) - ))) - - (quasisyntax/loc proc - (define-values (struct:CLOSURE make-CLOSURE CLOSURE? - #,@(if (null? fvars) - (syntax/loc proc ()) - (syntax/loc proc (CLOSURE-env set-CLOSURE-env!)))) - (let-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!) - (make-struct-type - '#,tag ;; the tag goes here - #f ; no super type - #,(if (null? fvars) 0 1) - 0 ; number of auto-fields - #f ; auto-v - - ; prop-vals: - (list (cons prop:serializable CLOSURE:serialize-info) - (cons prop:procedure - #,(if (null? fvars) - (quasisyntax/loc proc - (#%plain-lambda (clsr . args) - (#%plain-app apply #,proc args))) - (quasisyntax/loc proc - (#%plain-lambda (clsr . args) - (let-values ([#,fvars (#%plain-app - (#%plain-app CLOSURE-env clsr))]) - (#%plain-app apply #,proc args))))))) - - #f ; inspector - - ;; the struct apply proc: - #f)]) - (values struct:CLOSURE make-CLOSURE CLOSURE? - #,@(if (null? fvars) - (syntax/loc proc ()) - (syntax/loc proc - ((#%plain-lambda (clsr) (#%plain-app CLOSURE-ref clsr 0)) - (#%plain-lambda (clsr new-env) (#%plain-app CLOSURE-set! clsr 0 new-env))))))))))))) diff --git a/collects/web-server/private/define-closure.ss b/collects/web-server/private/define-closure.ss index 85a0fe0743..0b4395d888 100644 --- a/collects/web-server/private/define-closure.ss +++ b/collects/web-server/private/define-closure.ss @@ -1,15 +1,23 @@ #lang scheme/base -(require (for-syntax "closure.ss") - (for-syntax scheme/base) - (for-template scheme/base)) +(require (for-syntax scheme + web-server/lang/closure)) + (provide define-closure) (define-syntax (define-closure stx) (syntax-case stx () [(_ tag formals (free-vars ...) body) - (let-values ([(make-CLOSURE closure-definitions) - (make-closure-definition-syntax - #'tag - (syntax->list #'(free-vars ...)) - #`(lambda formals body))]) - #`(begin #,@closure-definitions))])) + (local + [(define-values (make-CLOSURE-id CLOSURE?-id CLOSURE-env-id) + (define-closure! #'tag #'(free-vars ...) (syntax/loc stx (lambda formals body)))) + (define make-tag + (datum->syntax stx (string->symbol (format "make-~a" (syntax->datum #'tag))) stx)) + (define tag-env + (datum->syntax stx (string->symbol (format "~a-env" (syntax->datum #'tag))) stx)) + (define tag? + (datum->syntax stx (string->symbol (format "~a?" (syntax->datum #'tag))) stx))] + (quasisyntax/loc stx + (begin + (define #,make-tag #,make-CLOSURE-id) + (define #,tag? #,CLOSURE?-id) + (define #,tag-env #,CLOSURE-env-id))))])) diff --git a/collects/web-server/scribblings/closure.scrbl b/collects/web-server/scribblings/closure.scrbl index 080d10c69d..e9a011c115 100644 --- a/collects/web-server/scribblings/closure.scrbl +++ b/collects/web-server/scribblings/closure.scrbl @@ -2,40 +2,34 @@ @(require "web-server.ss") @title[#:tag "closure.ss"]{Serializable Closures} -@(require (for-label web-server/private/closure +@(require (for-label scheme/serialize + web-server/lang/closure + web-server/lang/serial-lambda web-server/private/define-closure)) -@defmodule[web-server/private/closure]{ - + The defunctionalization process of the Web Language (see @secref["stateless" #:doc '(lib "web-server/scribblings/web-server.scrbl")]) -requires an explicit representation of closures that is serializable. This module provides that representation. +requires an explicit representation of closures that is serializable. -@defproc[(make-closure-definition-syntax [tag syntax?] - [fvars (listof identifier?)] - [proc syntax?]) - syntax?]{ - Outputs a syntax object that defines a serializable structure, - with @scheme[tag] as the tag, that represents a closure over - @scheme[fvars], that acts a procedure and when invoked calls - @scheme[proc], which is assumed to be syntax of @scheme[lambda] - or @scheme[case-lambda]. +@defmodule[web-server/lang/serial-lambda]{ + +@defform[(serial-lambda formals body ...)]{ + Returns @scheme[(lambda formals body ...)], except it is serializable. +} + +@defform[(serial-case-lambda [formals body ...] ...)]{ + Returns @scheme[(case-lambda [formals body ...] ...)], except it is serializable. +} + } -@defproc[(closure->deserialize-name [c closure?]) - symbol?]{ - Extracts the unique tag of a closure @scheme[c]. -} - -} - -These are difficult to use directly, so we provide a helper syntactic form: +@section[#:style 'hidden]{Definition Syntax} -@section[#:style 'hidden]{Define Closure} @defmodule[web-server/private/define-closure]{ -@defform[(define-closure tag formals (free-vars ...) body)]{ - Defines a closure, constructed with @scheme[make-tag] that accepts closure that returns - @scheme[freevars ...], that when invoked with @scheme[formals] +@defform[(define-closure tag formals (free-var ...) body)]{ + Defines a closure, constructed with @scheme[make-tag] that accepts a closure that returns + @scheme[freevar ...], that when invoked with @scheme[formals] executes @scheme[body]. }