Refer to here for more details.
I wrote a CPS transformer for Common Lisp in a few days after thinking in lisp terms only three months for now. I think it means lisp is great, actually I would never try to do the same thing in Java. -- Levente Mészáros
The code is not tested too much and I'm sure it can be improved. It's just a toy right now, but an interesting one, I think...
Also consider cl-cont - a delimited continuations library for Common Lisp initially written for cl-weblocks.
How does this one compare to Marco Baringer's transformer (used in UCW), part of his arnesi/bese tools? -- Jörg Höhle
I did take a look at Marco's stuff and this one is quite similar to that, although I don't know if arnesi uses explicit environments or relies on captured variables like this one. Actually I could not figure it out probably because of my little lisp experience. -- Levente Mészáros
After consulting with Marco, this is somewhat different in that it does not maintain during runtime its own environment (e.g. variable bindings), but relies on the VM's and on the fact that closures capture it.
Discussing with David Lichteblau I think the closure (the continuation) that is returned can be saved and restored via SB-HEAPDUMP (in SBCL), so you may have persistent continuations. Well, you already have them in arnesi/cc in a somewhat different way. -- Levente Mészáros
I have added a persistent continuation test below.
Code
#|
Copyright (C) 2006 Levente Mészáros melevy@freemail.hu
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
Except as contained in this notice, the name of the author shall
not be used in advertising or otherwise to promote the sale, use or
other dealings in this Software without prior written authorization
from the author.
|#
;;; names that already present in common lisp preceded by @ sign for clarity
;(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)))
(declaim (optimize (debug 0) (safety 0) (speed 3) (space 0)))
;; top level eval
(defun @eval (k)
(if (functionp k)
(funcall k #'ret/cc)
k))
;; top level eval restaring each time a continuation is returned by @eval
(defun @eval* (k)
(do ((k k (@eval k)))
((not (functionp k)) k)))
(defun cps-lambda (&rest forms)
`(lambda (k)
(declare (type function k))
,@forms))
(defun ret/cc (k)
k)
(defmacro let/cc (variable &rest forms)
`(call/cc
,(cps-lambda
`(let ((,variable k))
,@forms))))
(defconstant +special-forms+
'(progn if let let* setq block return-from declare tagbody go call/cc))
(defun @special-form-p (form)
(declare (type list form))
(member (the symbol (first form)) +special-forms+))
;; macros to generate CPS transformed code
(defun cps-transform-forms (forms)
(loop for f in forms
collect (cps-transform-form f)))
(defun cps-transform-forms* (forms)
(append '(list) (cps-transform-forms forms)))
(defun cps-transform-form (form)
(setq form (macroexpand form))
(if (or (atom form) (not (@special-form-p form)))
(cps-lambda `(funcall k ,form))
(ecase (first form)
(progn
(cps-lambda `(@progn k ,(cps-transform-forms* (cdr form)))))
(if
(cps-lambda `(@if k ,@(cps-transform-forms (cdr form)))))
(let*
#1=(cps-lambda
`(let (,@(loop for b in (second form)
collect (list (first b) nil)))
(@let* k
(list ,@(loop for b in (second form)
collect `(lambda (v) (setq ,(first b) v))))
(list ,@(loop for b in (second form)
collect (cps-transform-form (second b))))
,(cps-transform-forms* (cddr form))))))
(let
;; TODO: this is a temporary hack
(format t "Warning: using let* instead of let: ~A" form)
#1#)
(setq
(cps-lambda
`(funcall ,(cps-transform-form (third form))
(lambda (v)
(setq ,(second form) v)
(funcall k v)))))
(block
(cps-lambda `(let ((,(safe-symbol (second form)) k))
(@progn k ,(cps-transform-forms* (cddr form))))))
(return-from
(cps-lambda `(funcall ,(cps-transform-form (third form)) (safe-symbol (second form)))))
(tagbody
(let ((tagbody-forms (loop for f in (cdr form)
when (listp f)
collect (cps-transform-form f))))
(cps-lambda
`(labels ((_tagbody_ (v) (funcall k v))
,@(loop for f in (cdr form)
with i = 0
when (not (listp f))
collect (list (safe-symbol f)
'(k)
`(@progn k ,(append '(list) (nthcdr i tagbody-forms))))
when (listp f)
do (incf i)))
(@progn k ,(append '(list) tagbody-forms))))))
(go
(cps-lambda `(funcall #',(safe-symbol (second form)) #'_tagbody_)))
(declare
;; TODO: use type declarations
(format t "Warning: ignoring declaration ~A" form)
(cps-lambda '(funcall k nil)))
(call/cc
(second form)))))
;; top level cps macro defines three functions: name @name and @name*
(defmacro @defun (name args &rest forms)
(let ((f (cps-lambda
`(@progn k
,(cps-transform-forms* forms)))))
`(progn
(defun ,name ,args
,@forms)
(defun ,(intern (concatenate 'string "@" (symbol-name name))) ,args
(@eval ,f))
(defun ,(intern (concatenate 'string "@" (symbol-name name) "*")) ,args
(@eval* ,f)))))
;;; special forms
(defun @progn (k forms)
(declare (type function k) (type list forms))
(cond ((cdr forms) (funcall (the function (car forms))
(lambda (i)
(declare (ignore i))
(@progn k (cdr forms)))))
(forms (funcall (the function (car forms)) k))
(t (funcall k nil))))
(defun @if (k condition then &optional (else nil))
(declare (type function k condition then))
(funcall condition
(lambda (v)
(cond (v (funcall then k))
(else (funcall else k))
(t (funcall k nil))))))
(defun @let* (k variables values forms)
(declare (type function k) (type list variables values forms))
(if values
(funcall (the function (car values))
(lambda (v)
(funcall (the function (car variables)) v)
(@let* k (cdr variables) (cdr values) forms)))
(@progn k forms)))
(defun safe-symbol (symbol)
(intern (concatenate 'string "@" (symbol-name symbol) "@")))
;; for non CPS function
(defun call/cc (k)
(declare (ignore k))
nil)
Test
Try this to test (I have used LispWorks). Note how the continuation (a closure) is returned and reused. The speed is interestingly only x20 slower compared to normal compiled code. It probably comes from heavy memory usage as you can see from the timing.
CL-USER 7 > (@defun ii ()
(iter (for i from 0 to 3)
(call/cc #'ret/cc)
(collect i)))
@II*
CL-USER 8 > (ii)
(0 1 2 3)
CL-USER 9 > (@ii*)
(0 1 2 3)
CL-USER 10 > (@ii)
#<closure 206834B2>
CL-USER 11 > (@eval *)
#<closure 2068A0DA>
CL-USER 12 > (@eval *)
#<closure 2068D50A>
CL-USER 13 > (@eval *)
#<closure 20690FFA>
CL-USER 14 > (@eval *)
(0 1 2 3)
...
CL-USER 39 > (time (dotimes (x 100000) (ii)))
Timing the evaluation of (DOTIMES (X 100000) (II))
user time = 1.031
system time = 0.000
Elapsed time = 0:00:01
Allocation = 2464 bytes standard / 17603267 bytes conses
0 Page faults
NIL
CL-USER 40 > (time (dotimes (x 100000) (@ii*)))
Timing the evaluation of (DOTIMES (X 100000) (@II*))
user time = 18.328
system time = 0.000
Elapsed time = 0:00:18
Allocation = 821607408 bytes standard / 401503377 bytes conses
0 Page faults
NIL
CL-USER 41 >
CL-USER 42 > (@ii*)
(0 1 2 3)
Expansion
The above iter example expands into this:
(@EVAL (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(@PROGN K
(LIST (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(LET ((I NIL) (#:RESULT72 NIL) (#:END-POINTER73 NIL) (#:TEMP74 NIL))
(@LET* K
(LIST (LAMBDA (V) (SETQ I V))
(LAMBDA (V) (SETQ #:RESULT72 V))
(LAMBDA (V) (SETQ #:END-POINTER73 V))
(LAMBDA (V) (SETQ #:TEMP74 V)))
(LIST (LAMBDA (K) (DECLARE (TYPE FUNCTION K)) (FUNCALL K NIL))
(LAMBDA (K) (DECLARE (TYPE FUNCTION K)) (FUNCALL K NIL))
(LAMBDA (K) (DECLARE (TYPE FUNCTION K)) (FUNCALL K NIL))
(LAMBDA (K) (DECLARE (TYPE FUNCTION K)) (FUNCALL K NIL)))
(LIST (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(LET ((@NIL@ K))
(@PROGN K
(LIST (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(LABELS ((_TAGBODY_ (V) (FUNCALL K V))
(@LOOP-TOP-NIL@ (K)
(@PROGN K
(LIST (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K (+ I 1)))
(LAMBDA (V) (SETQ I V) (FUNCALL K V))))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(@IF K
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K (> I 3)))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL #'@LOOP-END-NIL@ #'_TAGBODY_))))
#'RET/CC
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(@PROGN K
(LIST (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL (LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K (LIST I)))
(LAMBDA
(V)
(SETQ #:TEMP74 V)
(FUNCALL K V))))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL (LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(@IF
K
(LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K #:RESULT72))
(LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL
K
(SEQ::SET-CDR
#:END-POINTER73
#:TEMP74)))
(LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL
(LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K #:TEMP74))
(LAMBDA
(V)
(SETQ #:RESULT72 V)
(FUNCALL K V))))))
(LAMBDA
(V)
(SETQ #:END-POINTER73 V)
(FUNCALL K V))))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K #:RESULT72)))))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL #'@LOOP-TOP-NIL@ #'_TAGBODY_)))))
(@LOOP-END-NIL@ (K) (@PROGN K (LIST))))
(@PROGN K
(LIST (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL (LAMBDA (K) (DECLARE (TYPE FUNCTION K)) (FUNCALL K -1))
(LAMBDA (V) (SETQ I V) (FUNCALL K V))))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL (LAMBDA (K) (DECLARE (TYPE FUNCTION K)) (FUNCALL K (+ I 1)))
(LAMBDA (V) (SETQ I V) (FUNCALL K V))))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(@IF K
(LAMBDA (K) (DECLARE (TYPE FUNCTION K)) (FUNCALL K (> I 3)))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL #'@LOOP-END-NIL@ #'_TAGBODY_))))
#'RET/CC
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(@PROGN K
(LIST (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K (LIST I)))
(LAMBDA (V) (SETQ #:TEMP74 V) (FUNCALL K V))))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL (LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(@IF K
(LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K #:RESULT72))
(LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL
K
(SEQ::SET-CDR
#:END-POINTER73
#:TEMP74)))
(LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL
(LAMBDA
(K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K #:TEMP74))
(LAMBDA
(V)
(SETQ #:RESULT72 V)
(FUNCALL K V))))))
(LAMBDA (V)
(SETQ #:END-POINTER73 V)
(FUNCALL K V))))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL K #:RESULT72)))))
(LAMBDA (K)
(DECLARE (TYPE FUNCTION K))
(FUNCALL #'@LOOP-TOP-NIL@ #'_TAGBODY_))))))
(LAMBDA (K) (DECLARE (TYPE FUNCTION K)) (FUNCALL K #:RESULT72))))))))))))))
Persistent continuation
Try SBCL and SB-HEAPDUMP and the CPS transformation above on the following example.
;(declaim (optimize (debug 3) (safety 3) (speed 0) (space 0)))
(declaim (optimize (debug 0) (safety 0) (speed 3) (space 0)))
(require :iterate)
(require :sb-heapdump)
(use-package :iterate)
(use-package :sb-heapdump)
(load "test/cps.lisp")
(defun store-continuation (k)
(sb-heapdump::dump-object k "continuation.heap" :force t :if-exists :rename-and-delete))
(defun restore-continuation ()
(load-dumpfile "continuation.heap"))
(@defun demo ()
(iter (for i from 0 to 3)
(call/cc #'ret/cc)
(collect i)))
(defun @start (f)
(let ((k (funcall f)))
(store-continuation k)
k))
(defun @continue ()
(let ((k (@eval (restore-continuation))))
(store-continuation k)
k))
(defun @run (f)
(do ((k (@start f) (@continue)))
((not (functionp k)) k)))
Persistent continuation test
The following is a test session using SBCL. Note where the system was restarted and how the continuation is used.
CL-USER> (@start #'@demo)
24576 bytes written
#<CLOSURE (LAMBDA (I)) {B2E6A5D}>
CL-USER>
; SBCL Port: 32822 Pid: 14363
...
CL-USER> (@continue)
; loading continuation.heap[0] mmap 0.0s fixup 0.001s done
24576 bytes written
#<CLOSURE (LAMBDA (I)) {B394CA5}>
CL-USER>
; SBCL Port: 32824 Pid: 14729
...
CL-USER> (@continue)
; loading continuation.heap[0] mmap 0.0s fixup 0.0s done
24576 bytes written
#<CLOSURE (LAMBDA (I)) {B3BC4D5}>
CL-USER> (@continue)
; loading continuation.heap[0] mmap 0.002s fixup 0.001s done
24576 bytes written
#<CLOSURE (LAMBDA (I)) {B3E44FD}>
CL-USER> (@continue)
; loading continuation.heap[0] mmap 0.0s fixup 0.0s done
4096 bytes written
(0 1 2 3)
CL-USER> (@run #'@demo)
49152 bytes written
; loading continuation.heap[0] mmap 0.001s fixup 0.0s done
49152 bytes written
; loading continuation.heap[0] mmap 0.0s fixup 0.001s done
49152 bytes written
; loading continuation.heap[0] mmap 0.001s fixup 0.0s done
49152 bytes written
; loading continuation.heap[0] mmap 0.003s fixup 0.001s done
4096 bytes written
(0 1 2 3)
programming tips