175 lines
5.7 KiB
Scheme
175 lines
5.7 KiB
Scheme
#lang scheme/base
|
||
(require mzlib/list
|
||
mzlib/plt-match
|
||
mzlib/serialize
|
||
"../private/define-closure.ss"
|
||
"../lang/web-cells.ss")
|
||
; XXX contract
|
||
(provide
|
||
|
||
;; AUXILLIARIES
|
||
abort
|
||
abort/cc
|
||
resume
|
||
the-cont-key
|
||
the-save-cm-key
|
||
safe-call?
|
||
the-undef
|
||
activation-record-list
|
||
current-saved-continuation-marks-and
|
||
kont-append-fun
|
||
|
||
;; "SERVLET" INTERFACE
|
||
send/suspend
|
||
|
||
;; "CLIENT" INTERFACE
|
||
dispatch-start
|
||
dispatch)
|
||
|
||
;; **********************************************************************
|
||
;; **********************************************************************
|
||
;; AUXILLIARIES
|
||
(define-struct mark-key ())
|
||
(define the-cont-key (make-mark-key))
|
||
(define the-save-cm-key (make-mark-key))
|
||
(define safe-call? (make-mark-key))
|
||
(define web-prompt (make-continuation-prompt-tag 'web))
|
||
|
||
(define (current-saved-continuation-marks-and key val)
|
||
(define c
|
||
(continuation-mark-set->list (current-continuation-marks web-prompt)
|
||
the-save-cm-key))
|
||
(if (empty? c)
|
||
(make-immutable-hash (list (cons key val)))
|
||
(hash-set (first c) key val)))
|
||
|
||
;; current-continuation-as-list: -> (listof value)
|
||
;; check the safety marks and return the list of marks representing the continuation
|
||
(define (activation-record-list)
|
||
(let* ([cm (current-continuation-marks web-prompt)]
|
||
[sl (continuation-mark-set->list cm safe-call?)])
|
||
(if (andmap (lambda (x)
|
||
(if (pair? x)
|
||
(car x)
|
||
x))
|
||
sl)
|
||
(begin #;(printf "Safe continuation capture from ~S with cm ~S~n" sl cm)
|
||
#;(printf "CMs: ~S~n" (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key)))
|
||
(reverse (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key))))
|
||
(error "Attempt to capture a continuation from within an unsafe context:" sl))))
|
||
|
||
;; abort: ( -> alpha) -> alpha
|
||
;; erase the stack and apply a thunk
|
||
(define (abort thunk)
|
||
#;(printf "abort ~S~n" thunk)
|
||
(abort-current-continuation web-prompt thunk))
|
||
|
||
;; with-continuation-marks : (listof (cons any1 any2)) (-> any3) -> any3
|
||
(define (with-continuation-marks cms thnk)
|
||
(match cms
|
||
[(list) (thnk)]
|
||
[(list-rest (cons cm-key cm-val) cms)
|
||
(with-continuation-mark cm-key cm-val
|
||
(with-continuation-marks cms thnk))]))
|
||
|
||
(define (with-continuation-marks/hash cms thnk)
|
||
(with-continuation-marks
|
||
(hash-map cms cons)
|
||
thnk))
|
||
|
||
;; resume: (listof (value -> value)) value -> value
|
||
;; resume a computation given a value and list of frame procedures
|
||
(define (resume frames val)
|
||
#;(printf "~S~n" `(resume ,frames ,val))
|
||
(match frames
|
||
[(list)
|
||
(apply values val)]
|
||
[(list-rest f fs)
|
||
(match f
|
||
[(vector #f #f)
|
||
(error 'resume "Empty frame")]
|
||
[(vector f #f)
|
||
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val)))
|
||
f)]
|
||
[(vector #f cms)
|
||
(with-continuation-mark the-save-cm-key cms
|
||
(with-continuation-marks/hash cms (lambda () (resume fs val))))]
|
||
[(vector f cms)
|
||
(resume (list* (vector f #f) (vector #f cms) fs) val)])]))
|
||
|
||
;; rebuild-cms : frames (-> value) -> value
|
||
(define (rebuild-cms frames thunk)
|
||
#;(printf "~S~n" `(rebuild-cms ,frames ,thunk))
|
||
(match frames
|
||
[(list)
|
||
(thunk)]
|
||
[(list-rest f fs)
|
||
(match f
|
||
[(vector f #f)
|
||
(rebuild-cms fs thunk)]
|
||
[(vector f cms)
|
||
(with-continuation-marks/hash cms (lambda () (rebuild-cms fs thunk)))])]))
|
||
|
||
(define (abort/cc thunk)
|
||
(call-with-continuation-prompt
|
||
thunk
|
||
web-prompt))
|
||
|
||
;; a serializable undefined value
|
||
(define-serializable-struct undef ())
|
||
(define the-undef (make-undef))
|
||
|
||
;; **********************************************************************
|
||
;; **********************************************************************
|
||
;; "SERVLET" INTERFACE
|
||
|
||
(define-closure kont x (wcs current-marks)
|
||
(abort (lambda ()
|
||
; Restoring the web-cells is separate from the continuation
|
||
(restore-web-cell-set! wcs)
|
||
(resume current-marks x))))
|
||
|
||
(define (kont-append-fun k f)
|
||
(define-values (wcs current-marks) ((kont-env k)))
|
||
(make-kont
|
||
(lambda ()
|
||
(values wcs
|
||
(append current-marks (list (vector f #f)))))))
|
||
|
||
;; send/suspend: (continuation -> response) -> request
|
||
;; produce the current response and wait for the next request
|
||
(define (send/suspend response-maker)
|
||
(with-continuation-mark safe-call? '(#t send/suspend)
|
||
(let ([current-marks (activation-record-list)]
|
||
[wcs (capture-web-cell-set)])
|
||
((lambda (k)
|
||
(abort (lambda ()
|
||
; Since we escaped from the previous context, we need to re-install the user's continuation-marks
|
||
(rebuild-cms current-marks (lambda () (response-maker k))))))
|
||
(make-kont (lambda () (values wcs current-marks)))))))
|
||
|
||
;; **********************************************************************
|
||
;; **********************************************************************
|
||
;; "CLIENT" INTERFACE
|
||
|
||
;; dispatch-start: (request -> response) request -> reponse
|
||
;; pass the initial request to the starting interaction point
|
||
(define (dispatch-start start req0)
|
||
(abort/cc
|
||
(lambda ()
|
||
(with-continuation-mark safe-call? '(#t start)
|
||
(start
|
||
(with-continuation-mark the-cont-key start
|
||
req0))))))
|
||
|
||
;; dispatch: (request -> (request -> response)) request -> response
|
||
;; lookup the continuation for this request and invoke it
|
||
(define (dispatch decode-continuation req)
|
||
(abort/cc
|
||
(lambda ()
|
||
(cond
|
||
[(decode-continuation req)
|
||
=> (lambda (k) (k req))]
|
||
[else
|
||
(error 'dispatch "no continuation associated with the provided request: ~S" req)]))))
|