From: Matthew Swank
Subject: stackhack attack
Date: 
Message-ID: <pan.2007.04.15.02.02.56.837276@c.net>
Joe Marshall outlines a clever way to capture continualtions in a pay as
you go sort of way in http://eval.apply.googlepages.com/stackhack4.html.

The code there is in C#.  The article is mostly meant for scheme
implementors compile to a VM the doesn't give you good access to the stack.

My interest lies in using the technique as a non-lisp implementor to
perhaps get more efficient code and still be able to use continuations in
Common Lisp.

However, in hacking of a simple version of the paper example I noticed
something: using condition handlers can be kind of expensive (at least in
sbcl).

The following code does not build any continuations.  It just sets up the
machinery to capture them.  All the overhead is associated with the code
annotations-- not capturing continuations.

;;;enough of the machinery to talk about theses examples-- see jrm for a
;;;complete implementation


(cl:defpackage :stackhack-post
  (:use :cl :sb-mop))

(cl:in-package :stackhack-post)

(define-condition save-continuation ()
  ((new-frames :initarg :new-frames
               :accessor new-frames)
   (old-frames :initarg :old-frames
               :accessor old-frames)))


;; the protocol in the article does closure conversion-- we can 
;; also just use closures
(defclass continuation-frame (funcallable-standard-object)
  ((continuation :initarg :continuation
                 :type list
                 :accessor continuation-of))
  (:metaclass funcallable-standard-class))

(defmethod initialize-instance ((o continuation-frame) 
                                &rest initargs &key &allow-other-keys)
  (let ((instance-function (getf initargs :instance-function nil)))
    (set-funcallable-instance-function 
     o (if (functionp instance-function) 
           instance-function
           #'(lambda (return-value)
               (invoke o return-value))))) 
  (call-next-method))

(defgeneric invoke (continuation-frame restart-value))

(defgeneric extend (save-continuation continuation-frame))

;; ahh, the classics :)
(defun fib (n)
  (if (< n 2)
      1
      (+ (fib (- n 1)) (fib (- n 2)))))

;; for comparision, here's a cps version
(defun fibk (k n)
  (if (< n 2)
      (funcall k 1) 
      (fibk #'(lambda (n-1)
                (fibk #'(lambda (n-2)
                          (funcall k (+ n-1 n-2)))
                      (- n 2))) 
            (- n 1))))


;;; first we do an anf transform then fragmentation of the
;;; various partial continuations we want to capture:

;; anf
(defun fib-an (n)
  (if (< n 2)
      1
      (let ((temp0 (fib-an (- n 1)))
            (temp1 (fib-an (- n 2))))
        (+ temp0 temp1))))


(defun fib-an-frag (n)
  (labels ((fib-an0 (temp0 n)
             (let ((temp1 (fib-an-frag (- n 2))))
               (fib-an1 temp0 temp1)))
           
           (fib-an1 (temp0 temp1)
             (+ temp0 temp1)))
    (if (< n 2)
        1
        (let ((temp0 (fib-an-frag (- n 1))))
          (fib-an0 temp0 n)))))

;;; here's the annotation using the condition system

(defun fib-anfrag-st (n)
  (labels ((fib-an0 (temp0 n)
             (let (temp1)
               (handler-case (setf temp1 (fib-anfrag-st (- n 2)))
                 (save-continuation (sc)
                   (extend sc (make-instance 'continuation-frame
                               :instance-function
                               #'(lambda (contin-val)
                                   (fib-an1 temp0 contin-val))))
                   (signal sc)))
               (fib-an1 temp0 temp1)))
           
           (fib-an1 (temp0 temp1)
             (+ temp0 temp1)))
    (if (< n 2)
        1
        (let (temp0)
          (handler-case (setf temp0 (fib-anfrag-st (- n 1)))
            (save-continuation (sc)
              (extend sc (make-instance 'continuation-frame
                          :instance-function
                          #'(lambda (contin-val)
                              (fib-an0 contin-val n))))
              (signal sc)))
          (fib-an0 temp0 n)))))

;;; here's the annotation using catch/throw
(defun fib-anfrag-ct (n)
  (labels ((fib-an0 (temp0 n)
             (let* (temp1
                    (sc (catch :sc (setf temp1 (fib-anfrag-ct (- n 2))))))
               (typecase sc 
                 (save-continuation 
                   (extend sc (make-instance 'continuation-frame
                               :instance-function
                               #'(lambda (contin-val)
                                   (fib-an1 temp0 contin-val))))
                   (throw :sc sc)))
               (fib-an1 temp0 temp1)))
           
           (fib-an1 (temp0 temp1)
             (+ temp0 temp1)))
    (if (< n 2)
        1
        (let* (temp0
               (sc (catch :sc (setf temp0 (fib-anfrag-ct (- n 1))))))
          (typecase sc 
            (save-continuation 
              (extend sc (make-instance 'continuation-frame
                          :instance-function
                          #'(lambda (contin-val)
                              (fib-an0 contin-val n))))
              (throw :sc sc)))
          (fib-an0 temp0 n)))))

;;; some timings

STACKHACK-POST> (time (fib 30))
Evaluation took:
  0.086 seconds of real time
  0.083988 seconds of user run time
  0.0 seconds of system run time
  0 calls to %EVAL
  0 page faults and
  0 bytes consed.
1346269
STACKHACK-POST> (time (fibk #'identity 30))
Evaluation took:
  0.42 seconds of real time
  0.386941 seconds of user run time
  0.023996 seconds of system run time
  [Run times include 0.168 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  43,083,504 bytes consed.
1346269
STACKHACK-POST> (time (fib-anfrag-st 30))
Evaluation took:
  0.848 seconds of real time
  0.825874 seconds of user run time
  0.003 seconds of system run time
  [Run times include 0.166 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  150,781,560 bytes consed.
1346269
STACKHACK-POST> (time (fib-anfrag-ct 30))
Evaluation took:
  0.292 seconds of real time
  0.276958 seconds of user run time
  0.0 seconds of system run time
  0 calls to %EVAL
  0 page faults and
  0 bytes consed.
1346269
STACKHACK-POST> 

Using the condition has more overhead, and is slower than the CPS
code, and were's not even capturing any activation records! Catch/throw is
not too bad though.

Matt

-- 
"You do not really understand something unless you can
 explain it to your grandmother." - Albert Einstein.

From: Paul Khuong
Subject: Re: stackhack attack
Date: 
Message-ID: <1176647020.262619.127120@y5g2000hsa.googlegroups.com>
On Apr 14, 10:02 pm, Matthew Swank
<································@c.net> wrote:
> Joe Marshall outlines a clever way to capture continualtions in a pay as
> you go sort of way inhttp://eval.apply.googlepages.com/stackhack4.html.
>
> The code there is in C#.  The article is mostly meant for scheme
> implementors compile to a VM the doesn't give you good access to the stack.
>
> My interest lies in using the technique as a non-lisp implementor to
> perhaps get more efficient code and still be able to use continuations in
> Common Lisp.

I've implemented the technique for CL last summer. The surely bit-
rotten code is at <http://www.discontinuity.info/~pkhuong/span/>. I
just added some quick optimisations in my tree (mostly inlining the
non-capturing path), but all the overhead in making the system safe
(e.g. detecting when we leave transformed code to then forbid
continuation capture) makes the system much slower than it could be.

It mangles fib into

(CA.PVK.CL-MONAD:MONAD-LAMBDA (N)
  (CA.PVK.CL-MONAD:BIND
   (CA.PVK.CL-MONAD:MONAD-FUNCALL (CA.PVK.CL-MONAD::MAYBE-MONAD-
FUNCTION <)
				  N
				  2)
   (CA.PVK.CL-MONAD:MONAD-LAMBDA (#:TEST1578)
     (IF #:TEST1578
	 1
	 (CA.PVK.CL-MONAD:BIND
	  (CA.PVK.CL-MONAD:MONAD-FUNCALL (CA.PVK.CL-MONAD::MAYBE-MONAD-
FUNCTION -)
					 N
					 1)
	  (CA.PVK.CL-MONAD:MONAD-LAMBDA (#:ARG1581)
	    (CA.PVK.CL-MONAD:BIND
	     (CA.PVK.CL-MONAD:MONAD-FUNCALL (CA.PVK.CL-MONAD::MAYBE-MONAD-
FUNCTION FIB-ANF)
					    #:ARG1581)
	     (CA.PVK.CL-MONAD:MONAD-LAMBDA (#:ARG1579)
	       (CA.PVK.CL-MONAD:BIND
		(CA.PVK.CL-MONAD:MONAD-FUNCALL (CA.PVK.CL-MONAD::MAYBE-MONAD-
FUNCTION -)
					       N
					       2)
		(CA.PVK.CL-MONAD:MONAD-LAMBDA (#:ARG1582)
		  (CA.PVK.CL-MONAD:BIND
		   (CA.PVK.CL-MONAD:MONAD-FUNCALL (CA.PVK.CL-MONAD::MAYBE-MONAD-
FUNCTION FIB-ANF)
						  #:ARG1582)
		   (CA.PVK.CL-MONAD:MONAD-LAMBDA (#:ARG1580)
		     (CA.PVK.CL-MONAD:MONAD-FUNCALL (CA.PVK.CL-MONAD::MAYBE-MONAD-
FUNCTION +)
                                                    #:ARG1579
 
#:ARG1580)))))))))))))

Where monad-funcall is
(defun monad-funcall (fn &rest args)
  (if (monadifiedp fn)
      (apply fn args)
      (let ((*in-monad* nil))
	(apply fn args))))

monad-lambda is a macro that conses up a funcallable object and maybe-
monad-function basically expands into (function [x]).

and bind is
(define-symbol-macro %%in-mainline t) ;; compilet-let hack

(defmacro bind (val fn &environment env)
  (let ((_receiver (gensym "RECEIVER"))
        (_frame    (gensym "FRAME"))
        (_fn       (gensym "FN"))
        (_subframes (gensym "SUBFRAMES"))
        (_value    (gensym "VALUE"))
        (_ignore   (gensym "IGNORE"))
        (mainlinep (macroexpand-1 '%%in-mainline env)))
    (if (and  mainlinep
              (consp fn)
              (eq (car fn)
                  'ca.pvk.cl-monad:monad-lambda))
        `((lambda ,(cadr fn)
            ,@(cddr fn))
          (block nil
            (destructuring-bind (,_frame ,_fn ,_subframes)
                (catch 'capture
                  (return ,val)) ; Helps w/ TCO by reducing the # of
nested catch
              (throw 'capture (list ,_frame
                                    ,_fn
                                    (cons (lambda (&optional ,_value
                                                   &rest ,_ignore)
                                            (declare
(ignore ,_ignore))
                                            ((lambda ,(cadr fn)
                                               (symbol-macrolet ((%%in-
mainline nil))
                                                 ,@(cddr fn)))
                                             ,_value))
                                          ,_subframes))))))
        `(let ((,_receiver ,fn))
           (funcall ,_receiver
                    (block nil
                      (destructuring-bind (,_frame ,_fn ,_subframes)
                          (catch 'capture
                            (return ,val))
                        (throw 'capture (list ,_frame
                                              ,_fn
                                              (cons (lambda
(&optional ,_value
 
&rest ,_ignore)
                                                      (declare
(ignore ,_ignore))
 
(funcall ,_receiver ,_value))
                                                    ,_subframes))))))))))


As for performance, (fib 30) takes between 0.07 and 0.23 seconds on my
machine. (fib-anf 30) takes ~6 seconds. However, I don't think the
transformation itself is to blame; it seems to be doing exactly what
it should. The slowdown can very probably be attributed to the way the
annotations are implemented. Those are much easier to change.

Paul Khuong
From: Matthew Swank
Subject: Re: stackhack attack
Date: 
Message-ID: <pan.2007.04.17.08.45.20.728434@c.net>
On Sun, 15 Apr 2007 07:23:40 -0700, Paul Khuong wrote:

> On Apr 14, 10:02 pm, Matthew Swank
> <································@c.net> wrote:
>> Joe Marshall outlines a clever way to capture continualtions in a pay as
>> you go sort of way inhttp://eval.apply.googlepages.com/stackhack4.html.
>>
>> The code there is in C#.  The article is mostly meant for scheme
>> implementors compile to a VM the doesn't give you good access to the stack.
>>
>> My interest lies in using the technique as a non-lisp implementor to
>> perhaps get more efficient code and still be able to use continuations in
>> Common Lisp.
> 
> I've implemented the technique for CL last summer. The surely bit-
> rotten code is at <http://www.discontinuity.info/~pkhuong/span/>. I
> just added some quick optimisations in my tree (mostly inlining the
> non-capturing path), but all the overhead in making the system safe
> (e.g. detecting when we leave transformed code to then forbid
> continuation capture) makes the system much slower than it could be.

The complete CL version of stackhack is at
http://paste.lisp.org/display/39845

No fancy code walking, but there are a couple of helper macros.  I
believe all of the code in in the appendix is implemented. The
non-local exits are handled with catch/throw, though the two exceptions
classes from the paper are still implemented as lisp conditions.

Matt
From: Matthew Swank
Subject: Re: stackhack attack
Date: 
Message-ID: <pan.2007.04.18.03.08.01.10498@c.net>
On Sun, 15 Apr 2007 07:23:40 -0700, Paul Khuong wrote:

> On Apr 14, 10:02 pm, Matthew Swank
> <································@c.net> wrote:
>> Joe Marshall outlines a clever way to capture continualtions in a pay as
>> you go sort of way inhttp://eval.apply.googlepages.com/stackhack4.html.
>>
>> The code there is in C#.  The article is mostly meant for scheme
>> implementors compile to a VM the doesn't give you good access to the stack.
>>
>> My interest lies in using the technique as a non-lisp implementor to
>> perhaps get more efficient code and still be able to use continuations in
>> Common Lisp.
> 
> I've implemented the technique for CL last summer. The surely bit-
> rotten code is at <http://www.discontinuity.info/~pkhuong/span/>. I
> just added some quick optimisations in my tree (mostly inlining the
> non-capturing path), but all the overhead in making the system safe
> (e.g. detecting when we leave transformed code to then forbid
> continuation capture) makes the system much slower than it could be.
> 

...

> 
> bind is
> (define-symbol-macro %%in-mainline t) ;; compilet-let hack
> 
> (defmacro bind (val fn &environment env)

So fn is always a compiler artifact that doesn't get turned into a closure
unless you need the continuation?

Matt

-- 
"You do not really understand something unless you
 can explain it to your grandmother." - Albert Einstein.
From: Paul Khuong
Subject: Re: stackhack attack
Date: 
Message-ID: <1176899298.882276.311240@e65g2000hsc.googlegroups.com>
On Apr 17, 11:08 pm, Matthew Swank
<································@c.net> wrote:
> On Sun, 15 Apr 2007 07:23:40 -0700, Paul Khuong wrote:
> > bind is
> > (define-symbol-macro %%in-mainline t) ;; compilet-let hack
>
> > (defmacro bind (val fn &environment env)
>
> So fn is always a compiler artifact that doesn't get turned into a closure
> unless you need the continuation?

Not exactly, it depends on whether the bind is in the entirely non-
capturing (`mainline') path or not. If it's in the non-capturing path
(which is communicated to the macro via the symbol-macrolet on `%%in-
mainline'), then I inline fn to avoid the consing up a closure and to
try and help the compiler. If not, then I try to avoid code explosion
and evaluate fn only in one place. I should probably use a FLET like
you do instead of evaluating fn; that would hopefully avoid not cons a
closure up unless absolutely needed.

Paul Khuong
From: Joe Marshall
Subject: Re: stackhack attack
Date: 
Message-ID: <1176752668.845893.285670@q75g2000hsh.googlegroups.com>
On Apr 14, 7:02 pm, Matthew Swank
<································@c.net> wrote:
>
> However, in hacking of a simple version of the paper example I noticed
> something: using condition handlers can be kind of expensive (at least in
> sbcl).

What is HANDLER-CASE expanding to?
From: Matthew Swank
Subject: Re: stackhack attack
Date: 
Message-ID: <pan.2007.04.16.23.40.19.773980@c.net>
On Mon, 16 Apr 2007 12:44:28 -0700, Joe Marshall wrote:

> On Apr 14, 7:02 pm, Matthew Swank
> <································@c.net> wrote:
>>
>> However, in hacking of a simple version of the paper example I noticed
>> something: using condition handlers can be kind of expensive (at least in
>> sbcl).
> 
> What is HANDLER-CASE expanding to?
(handler-case (setf temp1 (fib-anfrag-st (- n 2)))
  (save-continuation (sc)
    (extend sc (make-instance 'continuation-frame
                               :instance-function
                               #'(lambda (contin-val)
                                   (fib-an1 temp0 contin-val))))
    (signal sc)))
->
(BLOCK #:G1540
  (LET ((#:G1541 NIL))
    (DECLARE (IGNORABLE #:G1541))
    (TAGBODY
      (LET ((SB-KERNEL:*HANDLER-CLUSTERS*
             (CONS
              (LIST
               (CONS 'SAVE-CONTINUATION
                     (LAMBDA (SB-IMPL::TEMP)
                       (SETQ #:G1541 SB-IMPL::TEMP)
                       (GO #:G1542))))
              SB-KERNEL:*HANDLER-CLUSTERS*)))
        (MULTIPLE-VALUE-PROG1
            (PROGN
              (RETURN-FROM #:G1540
                (MULTIPLE-VALUE-PROG1 (SETF TEMP1 (FIB-ANFRAG-ST (- N 2)))
                  (SB-KERNEL:FLOAT-WAIT))))
          (SB-KERNEL:FLOAT-WAIT)))
     #:G1542
      (RETURN-FROM #:G1540
        (LET ((SC #:G1541))
          (EXTEND SC
                  (MAKE-INSTANCE 'CONTINUATION-FRAME :INSTANCE-FUNCTION
                                 #'(LAMBDA (CONTIN-VAL)
                                     (FIB-AN1 TEMP0 CONTIN-VAL))))
          (SIGNAL SC))))))

-- 
"You do not really understand something unless you
 can explain it to your grandmother." - Albert Einstein.
From: Paul Khuong
Subject: Re: stackhack attack
Date: 
Message-ID: <1176773517.880506.236390@b75g2000hsg.googlegroups.com>
On Apr 16, 7:40 pm, Matthew Swank
<································@c.net> wrote:
> On Mon, 16 Apr 2007 12:44:28 -0700, Joe Marshall wrote:
> > What is HANDLER-CASE expanding to?
>
> (handler-case (setf temp1 (fib-anfrag-st (- n 2)))
>   (save-continuation (sc)
>     (extend sc (make-instance 'continuation-frame
>                                :instance-function
>                                #'(lambda (contin-val)
>                                    (fib-an1 temp0 contin-val))))
>     (signal sc)))
> ->
> (BLOCK #:G1540
>   (LET ((#:G1541 NIL))
>     (DECLARE (IGNORABLE #:G1541))
>     (TAGBODY
>       (LET ((SB-KERNEL:*HANDLER-CLUSTERS*
>              (CONS
>               (LIST
>                (CONS 'SAVE-CONTINUATION
>                      (LAMBDA (SB-IMPL::TEMP)
>                        (SETQ #:G1541 SB-IMPL::TEMP)
>                        (GO #:G1542))))
>               SB-KERNEL:*HANDLER-CLUSTERS*)))
[...]

If you're consing up a new closure and pushing it on a list, you might
as well create the activation frame's closure instead and build the
continuation eagerly. It'll probably still be slower than throw/catch
(it's far from not penalising non-capturing code, although the control
flow is much simpler), but at least capture will be simple and fast.

Paul Khuong
From: Matthew Swank
Subject: Re: stackhack attack
Date: 
Message-ID: <pan.2007.04.16.23.59.09.701353@c.net>
On Mon, 16 Apr 2007 18:40:20 -0500, Matthew Swank wrote:

> On Mon, 16 Apr 2007 12:44:28 -0700, Joe Marshall wrote:
> 
>> On Apr 14, 7:02 pm, Matthew Swank
>> <································@c.net> wrote:
>>>
>>> However, in hacking of a simple version of the paper example I noticed
>>> something: using condition handlers can be kind of expensive (at least in
>>> sbcl).
>> 
>> What is HANDLER-CASE expanding to?
using handler-bind helps a little bit but it still can't compare to
catch/throw:
STACKHACK-POST> (time (fib-anfrag-st 30)) ;;handler-case
Evaluation took:
  0.949 seconds of real time
  0.915861 seconds of user run time
  0.029995 seconds of system run time
  [Run times include 0.249 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  150,779,312 bytes consed.
1346269
STACKHACK-POST> (time (fib-anfrag-hb 30)) ;;handler-bind
Evaluation took:
  0.628 seconds of real time
  0.608907 seconds of user run time
  0.004 seconds of system run time
  [Run times include 0.133 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  107,696,800 bytes consed.
1346269
STACKHACK-POST> (time (fib-anfrag-ct 30)) ;;catch-throw
Evaluation took:
  0.272 seconds of real time
  0.271959 seconds of user run time
  0.0 seconds of system run time
  0 calls to %EVAL
  0 page faults and
  0 bytes consed.
1346269
STACKHACK-POST> 

-- 
"You do not really understand something unless you
 can explain it to your grandmother." - Albert Einstein.
From: Joe Marshall
Subject: Re: stackhack attack
Date: 
Message-ID: <1176846625.347935.234950@n59g2000hsh.googlegroups.com>
On Apr 16, 4:40 pm, Matthew Swank
<································@c.net> wrote:
> On Mon, 16 Apr 2007 12:44:28 -0700, Joe Marshall wrote:
> > On Apr 14, 7:02 pm, Matthew Swank
> > <································@c.net> wrote:
>
> >> However, in hacking of a simple version of the paper example I noticed
> >> something: using condition handlers can be kind of expensive (at least in
> >> sbcl).
>
> > What is HANDLER-CASE expanding to?
>
> (handler-case (setf temp1 (fib-anfrag-st (- n 2)))
>   (save-continuation (sc)
>     (extend sc (make-instance 'continuation-frame
>                                :instance-function
>                                #'(lambda (contin-val)
>                                    (fib-an1 temp0 contin-val))))
>     (signal sc)))
> ->
> (BLOCK #:G1540
>   (LET ((#:G1541 NIL))
>     (DECLARE (IGNORABLE #:G1541))
>     (TAGBODY
>       (LET ((SB-KERNEL:*HANDLER-CLUSTERS*
>              (CONS
>               (LIST
>                (CONS 'SAVE-CONTINUATION
>                      (LAMBDA (SB-IMPL::TEMP)
>                        (SETQ #:G1541 SB-IMPL::TEMP)
>                        (GO #:G1542))))
>               SB-KERNEL:*HANDLER-CLUSTERS*)))
>         (MULTIPLE-VALUE-PROG1
>             (PROGN
>               (RETURN-FROM #:G1540
>                 (MULTIPLE-VALUE-PROG1 (SETF TEMP1 (FIB-ANFRAG-ST (- N 2)))
>                   (SB-KERNEL:FLOAT-WAIT))))
>           (SB-KERNEL:FLOAT-WAIT)))
>      #:G1542
>       (RETURN-FROM #:G1540
>         (LET ((SC #:G1541))
>           (EXTEND SC
>                   (MAKE-INSTANCE 'CONTINUATION-FRAME :INSTANCE-FUNCTION
>                                  #'(LAMBDA (CONTIN-VAL)
>                                      (FIB-AN1 TEMP0 CONTIN-VAL))))
>           (SIGNAL SC))))))
>

That's nasty.

The control flow looks pretty hairy in this.  I imagine the compiler
is having a hard
time figuring out how to compile this optimally.  Since there is a
lexical `go' in
the tagbody, there's going to be a catch frame associated with the
tagbody.
There might be one associated with the block, too.  The MV-PROG1s are
going
to have to temporarily store the return values, too.
From: Matthew Swank
Subject: Re: stackhack attack
Date: 
Message-ID: <pan.2007.04.17.02.37.54.306534@c.net>
On Sat, 14 Apr 2007 21:02:57 -0500, Matthew Swank wrote:

> The following code does not build any continuations.  It just sets up the
> machinery to capture them.  All the overhead is associated with the code
> annotations-- not capturing continuations.
> 
;;curiouser-- inlining seems *more* expensive than fragmentation
;;given the following macros that use catch/throw:

(defmacro sh-progn (&body body)
  (cond ((null body) nil)
        ((null (cdr body))
         (car body))
        (t (let ((sc (gensym))
                 (v (gensym)))
             `(let ((,sc (catch 'save-continuation ,(car body) nil))) 
                (when (typep ,sc 'save-continuation)
                  (extend ,sc 
                          (make-instance 'continuation-frame
                           :instance-function  #'(lambda (,v) 
                                                   (declare (ignore ,v))
                                                   (sh-progn ,@(cdr body)))))
                  (throw 'save-continaution ,sc))
                (sh-progn ,@(cdr body)))))))

(defmacro sh-let* ((&rest bindings)
                   &body body)
  (unless bindings (return-from sh-let* `(sh-progn ,@body)))
  (let ((sc (gensym))
        (var (caar bindings))
        (form (cadar bindings)))
    `(let* (,var
            (,sc (catch 'save-continuation (setf ,var ,form) nil))) 
       (when (typep ,sc 'save-continuation)
         (extend ,sc 
                  (make-instance 'continuation-frame
                   :instance-function
                   #'(lambda (,var) 
                       (declare (ignorable ,var))
                       (sh-let* ,(cdr bindings) ,@body))))
          (throw 'save-continuation ,sc))
       (sh-let* ,(cdr bindings) ,@body))))

;;and
(defun fib-ct (n)
  (if (< n 2)
      1
      (sh-let* ((temp0 (fib-ct (- n 1)))
                (temp1 (fib-ct (- n 2))))
        (+ temp1 temp0))))
STACKHACK> (time (fib-ct 30))
Evaluation took:
  0.305 seconds of real time
  0.301954 seconds of user run time
  0.0 seconds of system run time
  [Run times include 0.015 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  10,772,480 bytes consed.
1346269
compared to 

STACKHACK> (time (fib-anfrag-ct 30))
Evaluation took:
  0.25 seconds of real time
  0.249962 seconds of user run time
  0.0 seconds of system run time
  0 calls to %EVAL
  0 page faults and
  0 bytes consed.
1346269
STACKHACK> 
 
for the catch/thow implementation in the original post
Why would nested scoping cause more consing than local functions?

For the impatient this is what fib-st really looks like:

(DEFUN FIB-ST (N)
(IF (< N 2) 1
    (LET* (TEMP0
           (SC (CATCH 'SAVE-CONTINUATION (SETF TEMP0 (FIB-ST (- N 1)))
           NIL)))
      (WHEN (TYPEP SC 'SAVE-CONTINUATION)
        (EXTEND SC
                (MAKE-INSTANCE 
                 'CONTINUATION-FRAME 
                 :INSTANCE-FUNCTION
                 #'(LAMBDA (TEMP0)
                     (DECLARE (IGNORABLE TEMP0))
                     (LET* (TEMP1 
                           (SC (CATCH 'SAVE-CONTINUATION 
                                      (SETF TEMP1
                                           (FIB-ST (- N 2)))
                                      NIL)))
                       (WHEN (TYPEP SC 'SAVE-CONTINUATION)
                         (EXTEND SC (MAKE-INSTANCE
                                      'CONTINUATION-FRAME
                                      :INSTANCE-FUNCTION
                                      #'(LAMBDA (TEMP1)
                                          (DECLARE (IGNORABLE TEMP1))
                                          (+ TEMP1 TEMP0))))
                         (THROW 'SAVE-CONTINUATION SC))
                       (+ TEMP1 TEMP0)))))
        (THROW 'SAVE-CONTINUATION SC))
      (LET* (TEMP1
             (SC (CATCH 'SAVE-CONTINUATION (SETF TEMP1 (FIB-ST (- N 2)))
             NIL)))
        (WHEN (TYPEP SC 'SAVE-CONTINUATION)
          (EXTEND SC (MAKE-INSTANCE 'CONTINUATION-FRAME 
                                    :INSTANCE-FUNCTION
                                    #'(LAMBDA (TEMP1)
                                        (DECLARE (IGNORABLE TEMP1))
                                        (+ TEMP1 TEMP0))))
          (THROW 'SAVE-CONTINUATION SC))
        (+ TEMP1 TEMP0)))))
Matt

-- 
"You do not really understand something unless you
 can explain it to your grandmother." - Albert Einstein.
From: Matthew Swank
Subject: Re: stackhack attack
Date: 
Message-ID: <pan.2007.04.17.05.09.52.922061@c.net>
On Mon, 16 Apr 2007 21:37:59 -0500, Matthew Swank wrote:

> On Sat, 14 Apr 2007 21:02:57 -0500, Matthew Swank wrote:
> 
>> The following code does not build any continuations.  It just sets up the
>> machinery to capture them.  All the overhead is associated with the code
>> annotations-- not capturing continuations.
>> 
> ;;curiouser-- inlining seems *more* expensive than fragmentation
> 
here's the insanity (well, I felt less than sane when I first saw it)

Let's let the macros do our fragmentation for us:

(defmacro sh-progn (&body body)
  (cond ((null body) nil)
        ((null (cdr body))
         (car body))
        (t (let ((sc (gensym))
                 (v (gensym))
                 (k (gensym)))
             `(flet ((,k ()
                       (sh-progn ,@(cdr body))))
                (let ((,sc (catch 'save-continuation ,(car body) nil))) 
                  (when ,sc
                    (extend ,sc 
                            (make-instance 'continuation-frame
                             :instance-function  #'(lambda (,v) 
                                                     (declare (ignore ,v))
                                                     (,k))))
                    (throw 'save-continuation ,sc))
                  (,k)))))))

(defmacro sh-let* ((&rest bindings)
                   &body body)
  (unless bindings (return-from sh-let* `(sh-progn ,@body)))
  (let ((sc (gensym))
        (var (caar bindings))
        (form (cadar bindings))
        (k (gensym)))
    `(flet ((,k (,var)
              (declare (ignorable ,var))
              (sh-let* ,(cdr bindings) ,@body)))
       (let* (,var
            (,sc (catch 'save-continuation (setf ,var ,form) nil))) 
       (when ,sc
         (extend ,sc 
                  (make-instance 'continuation-frame
                   :instance-function
                   #'(lambda (,var) ;;See *Note*
                       (declare (ignorable ,var))
                       (,k ,var))))
          (throw 'save-continuation ,sc))
       (,k ,var)))))

(defun fib-ct (n)
  (if (< n 2)
      1
      (sh-let* ((temp0 (fib-ct (- n 1)))
                (temp1 (fib-ct (- n 2))))
        (+ temp0 temp1))))
now has this behavior:

STACKHACK> (time (fib-ct 30))
Evaluation took:
  0.116 seconds of real time
  0.113982 seconds of user run time
  0.0 seconds of system run time
  0 calls to %EVAL
  0 page faults and
  0 bytes consed.
1346269

This has a lot better memory use than the inline version, and is in line
with the hand fragmented code. It's also only 30% slower than the
unannotated version.
 
*Note*: in sh-let* there is this construction:
  #'(lambda (,var)
      (declare (ignorable ,var))
      (,k ,var))

I could have substituted 
  #',k
However, that would (and did) cause sbcl to cons k.

Is this now over optimized for sbcl?

Can I expect other lisps to treat the flets in this way?

I don't have time to find out right now, but I would be fascinated by the
answer.

Matt

-- 
"You do not really understand something unless you
 can explain it to your grandmother." - Albert Einstein.