"winder-passing style", dynamic-wind, call-with-WINDING-continuation, etc.

[Matthias Blume <blume@CS.Princeton.EDU>]

To all those who are no longer following comp.lang.scheme....

This is something I just posted there:
---------------------------------------------------------------

Newsgroups: comp.lang.scheme
Subject: "Winder-passing style" (Re: R5RS call/cc & dynamic-wind ...)
From: blume@ux03.cs.princeton.edu (Matthias Blume)
Date: 17 May 1998 17:35:59 -0400
Organization: Princeton University, Department of Computer Science

More on this [ dynamic-wind business ] ...

Here is an implementation/explanation of dynamic-wind and
call-with-winding-continuation that does not rely on destructive
update.  I have alluded to that in my previous article [ in c.l.s ].

Of course, the implementation below is not meant to be a serious
proposal for *implementing* call/wc and dynamic-wind _at the language
surface_.  But it shows how these "features" could be explained in
denotational semantics.  Furthermore, Scheme compilers could use this
"winder-passing-style" as their intermediate representation (along the
lines of the familiar continuation- and closure-passing styles).

In the implementation, all functions have an additional argument that
represents the current winding context together with its depth
(length).  A winding context is simply a list of pairs of before/after
thunks.  (I need to be able to detect the case where two contexts are
identical. In Scheme I use eq? for that. In denotational semantics one
would have to use some kind of explicit unique tags.)

Most functions simply pass the winding context around unchanged.
DYNAMIC-WIND creates new winding contexts, and the escape procedures
created by call-with-winding-continuation use the auxiliary function
"wind" to run the appropriate set of before/after thunks.

An implementation based on this proposal has the advantage that it is
well-defined what happens if someone uses call/cc instead of call/wc
in a program that also uses dynamic-wind: An escape-procedure created
by call/cc (in my code this is called CALL-WITH-CURRENT-CONTINUATION-WPS)
will not run any of the before/after thunks between "there" and
"here", but it _will_ restore the correct winding context.  This is
in contrast to the code shown in the "meeting paper" where using (the
original) call/cc would leave the global data structure used for
winding in an incorrect state because no rerooting of the winder tree
would take place.

Also, the lack of destructive updates counts as a definite plus in my
book...  (... which, of course, is not unrelated to those previously
mentioned advantages).

-Matthias

Here is the code.  An example of "factorial" in winder-passing style
is added at the bottom.
;------------------------------------SNIP--------------------------
;; winding arg: (<wc> . <i>)
;;  where <wc> is a list of pairs of the form ((<before> . <after>) ...)
;;  and where <i> = (length <wc>)

;; we need a call/cc in "winder-passing style":
(define (call-with-current-continuation-wps here f)
  (call-with-current-continuation
   (lambda (k)
     (f here
	(lambda (ignore x)
	  (k x))))))

;; auxiliary function to do the unwinding/rewinding:
(define (wind from to)

  ;; if both winding contexts are equally long:
  (define (unwind-rewind from-wc i to-wc)
    (if (eq? from-wc to-wc)
	'()
	(let ((after-from (cdar from-wc))
	      (before-to (caar to-wc))
	      (from-wc (cdr from-wc))
	      (to-wc (cdr to-wc))
	      (i (- i 1)))
	  (after-from (cons from-wc i))
	  (unwind-rewind from-wc i to-wc)
	  (before-to (cons to-wc i)))))

  ;; if the "from" context is longer than the "to" context:
  (define (unwind-more diff from-wc from-i to-wc)
    (if (zero? diff)
	(unwind-rewind from-wc from-i to-wc)
	(let ((after-from (cdar from-wc))
	      (from-wc (cdr from-wc))
	      (from-i (- from-i 1))
	      (diff (- diff 1)))
	  (after-from (cons from-wc from-i))
	  (unwind-more diff from-wc from-i to-wc))))

  ;; if the "from" context is shorter than the "to"-context:
  (define (rewind-more diff from-wc to-wc to-i)
    (if (zero? diff)
	(unwind-rewind from-wc to-i to-wc)
	(let ((before-to (caar to-wc))
	      (to-wc (cdr to-wc))
	      (to-i (- to-i 1))
	      (diff (+ diff 1)))
	  (rewind-more diff from-wc to-wc to-i)
	  (before-to (cons to-wc to-i)))))

  (let* ((from-wc (car from))
	 (from-i (cdr from))
	 (to-wc (car to))
	 (to-i (cdr to))
	 (diff (- from-i to-i)))

    ;; do simple case analysis and call appropriate function
    (cond ((< diff 0) (rewind-more diff from-wc to-wc to-i))
	  ((> diff 0) (unwind-more diff from-wc from-i to-wc))
	  (else (unwind-rewind from-wc from-i to-wc)))))

;; here is where it's at...
(define (call-with-winding-continuation here f)
  (call-with-current-continuation-wps
   here
   (lambda (here k)
     (f here
	(lambda (there x)
	  (wind there here)
	  ;; alternative fast-path shortcut for the previous line:
	  ;; (if (not (eq? (car there) (car here))) (wind there here))
	  (k here x))))))

(define (dynamic-wind here before middle after)
  (before here)
  (let* ((new-here (cons (cons (cons before after) (car here))
			 (+ (cdr here) 1)))
	 (result (middle new-here)))
    (after here)
    result))

;------------------------------------SNIP-----------------------
;; Example: Fibonacci test code (with some bells and whistles to
;; demonstrate winding/unwinding):

;; make initial winding context
(define (nothing here) '())
(define here (cons (List (cons nothing nothing)) 0))

;; global variable for storing continuation
(define global-k #f)

;; global flag to control whether factorial should bail out
(define escape #f)

;; exit continuation;  after bailing out, the value of exit will be: ESCAPED!
(define exit
  (call-with-winding-continuation
   here
   (lambda (here k) k)))

;; factorial (+ winding test code) in winder-passing style
(define (fac-wps here n)
  (if (zero? n)
      (call-with-winding-continuation
       here
       (lambda (here k)
	 (set! global-k k)
	 (if escape
	     (exit here 'escaped!)
	     1)))
      (dynamic-wind
       here
       (lambda (here) (write (list 'Enter: n)) (newline))
       (lambda (here) (* n (fac-wps here (- n 1))))
       (lambda (here) (write (list 'Enter: n)) (newline)))))