Showing posts with label weblocks. Show all posts
Showing posts with label weblocks. Show all posts

Sunday, November 30, 2008

Understanding cl-cont semantics without thinking about CPS

Understanding the way that cl-cont transforms forms is one way to understand the sometimes counterintuitive behavior of that code. However, the difficulty of dissecting the meaning of code written in continuation-passing style is one of the major reasons that we use a CPS transformer at all instead of writing it out manually.

As a cl-cont user, you may find it easier to understand a behavior model that removes consideration of CPS entirely. After all, CPS is only the implementation method; the goal is to think of the code as "continuable".

Understanding first

To follow along with the behavior model of cl-cont, you should be familiar with dynamic context (such as that established by unwind-protect), lexical context, and the behavior of full continuations such as you would find in Scheme.

Understanding "ordinary" continuations is especially important, because cl-cont's behavior is more complex than full continuations, and you will be lost without preexisting knowledge of what they are.

Defining some terms

First, a continuation, unless otherwise qualified, is always a first-class continuation—a function that, when called, returns its arguments as values to the place where the call/cc call that created the continuation was called. This is just to be clear that I hardly ever mean something abstract when I say "continuation".

The macro with-call/cc introduces a lexical continuable context for the forms lexically contained within it. We will refer to this so often that I will call it LCC henceforth to avoid confusion. For all current purposes, it only matters whether code exists within any LCC, so you can think of "LCC-ness" as a flag on all code. We also say that any code not within an LCC is in an LNCC (lexical non-continuable context). We will define more rules for determining whether code is in an LCC later.

Entering an LCC at the beginning creates a dynamic continuable context or DCC. Understanding DCC behavior is the key to understanding cl-cont. Unlike LCC, you can have multiple distinct DCCs active at any time, possibly even sharing code, just as one function calling mapcar doesn't preclude you from doing so. All code not executing within a DCC is executing within a DNCC (dynamic non-continuable context).

Lexical continuable contexts

As I have said, with-call/cc introduces an LCC. This is an implicit progn. A few convenient macros, such as lambda/cc and defun/cc, wrap their non-cc counterparts with with-call/cc. Within this form, an LNCC can be inserted with the macro without-call/cc. The pseudo-function call/cc also implies a without-call/cc around its sole argument. Within any LNCC, including the implicit one around every program, further LCCs may be introduced with with-call/cc.

There are some cases where you might think that an LCC is there or doesn't matter, where it actually does. In this code:

(defun x ()
(with-call/cc
1 2))

The LCC only contains the 1 and 2 forms, not the function entry and function exit. Therefore, calling X from any code will result in first executing code in an LNCC, then some LCC code, then some LNCC code. The importance of this distinction will become clear once we start discussing DCCs. To solve this, move the with-call/cc to outside the defun, or use the equivalent defun/cc convenience macro.

A similar situation holds for this code:

(lambda () (with-call/cc 3 4))

Calling this function is the same as calling X above, and the same solutions apply.

One final area of confusion may be:

(with-call/cc
(without-call/cc
(with-call/cc 5 6)))

This is not a smooth contour of an LCC; the without-call/cc always creates an LNCC, even if a new one is created immediately therein.

Basic DCC execution

Entering any LCC from a DNCC, by either calling a function created or defined in an LCC or simply evaluating a with-call/cc form, creates a DCC. Upon creation, beyond the usual frame info, one property is captured and saved permanently for that DCC: the exit point. Consider this code:

(defun/cc bob ()
(cons 4 2)
:bob)
(defun/cc slack ()
(bob)
:slack)
(defun moo ()
(bob)
(slack))

Calling bob in moo creates a DCC whose exit point is the code that returns the keyword :bob. Calling slack in moo creates another one whose exit point is returning :slack. The call to bob within the call to slack does not create a new DCC, or even alter the existing one! Whether calling bob creates a new DCC depends on the nature of the calling code.

While in a DCC, calling a function defined in an LNCC suspends that DCC. That happens in bob above when calling cons, which, like all CL standard functions, is defined in some LNCC. Whether the compiler optimizes away the cons is irrelevant to our semantic model. When the function returns, the same DCC is resumed; as such, the cons above destroys neither DCC's exit point information.

The function rule sounds like a special case, but it is really just a subcase of the continuation case. Invoking a continuation enters the DCC in which it was created. In cl-cont, calling LNCC functions is handled by grabbing the continuationand invoking it with the function's result after it finishes.

After exiting a DCC, the only way to reenter it is to invoke one of its continuations. Calling a function defined therein only creates a new DCC delimited by that function's body.

Finally, a point about call/cc that will surprise you if you are used to Scheme: Invoking call/cc exits the DCC, returning the values returned by the function you gave it. You are, of course, free to simulate Scheme behavior by invoking the continuation from right within that function.

Strange exit point behavior

This may seem a little surprising:

(defvar *cc*)
(defun/cc foo ()
(let/cc cc (setf *cc* cc) 'saved)
'foo)

(defun/cc bar ()
(foo)
'bar)

(progn
(foo) ; ⇒SAVED
(funcall *cc*) ; ⇒FOO
(bar) ; ⇒SAVED
(funcall *cc*) ; ⇒BAR
)

The important thing to remember is that it doesn't matter at all what context you invoke a continuation in from a DNCC; you always get the exit point of the continuation's DCC.

Nested DCCs

Certain code looks like it should really be resuming something that it actually can't, and it has to do with nesting DCCs. Here's what I mean:

(let (keep-going list)
(progn (with-call/cc
(setf list (mapcar (lambda (n)
(let/cc k (setf keep-going k) 42))
(list 1 2 3 4 5))))
(dotimes (n 5)
(funcall keep-going (+ n 6)))
list))

If mapcar was defined in an LCC, you would get the result you expect, (6 7 8 9 10). What you expect is that for each element in (1 2 3 4 5), let/cc saves and suspends the continuation.. The first time, the dotimes would be entered, and the next four times it would do another iteration, each time invoking the continuation saved above. In the first case, the 42 would be delivered to the first progn location (and discarded), and the further four times to the implicit progn in dotimes (and discarded).

Instead, you get the result (42 42 42 42 42). Why?

The mapcar throws a kink in. Consider that when mapcar is running, the enclosing DCC is suspended, because mapcar is defined in an LNCC and therefore creates a DNCC by being called. Now, when it calls the LCC-defined function passed to it, a new DCC is created each time. In each of these a continuation is saved and 42 is returned, creating the contents of the list, but only the last saved continuation is ever seen by the dotimes. When mapcar finishes, it resumes the enclosing continuation and it finishes execution before the dotimes can even start.

Now that dotimes has started, it is resuming the DCC solely delimited by the function passed to mapcar. As you can see, the exit point of that function is to return whatever was passed to the continuation. Accordingly, if you wrap the funcall above with a print, you'll see it print 6, 7, 8, 9, and 10, in order.

Tuesday, September 2, 2008

Fixing weblocks test failures, try 1

Here we commemorate the demise of the first test fixing branch of Weblocks, c6dc18-test-fixes. At its peak, it got the number of failures in the ~750 test suite down to a whopping 9. Shortly after its merge back into dev, the count was back up to over 50.

As I write this, the count on my new fixes branch is 84. On the now 4-patch divergent dev, a trial merge into the fixes branch raises that to 89. (To be entirely fair, I was the committer of the revisions that caused the jump.)

There is a lesson here about test discipline. Once you get out of the mindset of making every mainline rev pass all tests, it's hard to get back in. For quite a while my fix strategy has been a little lax.
  1. If it's small, and I don't think it does much, don't bother testing.
  2. For large changes, make sure the failure count doesn't jump above 100.
  3. Whatever, just make sure my development site (which doesn't even use continuations yet) works.
Symmetric merging is little help here, as all the revs in a topic branch end up as first-class revs in the mainline. Not that I blame Mercurial at all; still, I hope to build future features in topic branches posted on Bitbucket, preferably with optimized archival storage (backporting hardlinks and such) so dormant branches, such as c6dc18-test-fixes, can stay around forever cheaply.

I think the failure with c6dc18-test-fixes was not providing public feedback about how the failure counts were diverging between branches. Now I have scripts that merge, test, and compare test results on two branches, so I can generate all the useless statistics I like.

Friday, August 15, 2008

A metaclass for weblocks-webapps, try 3

This one includes mostly the same shared-initialize and defwebapp contents, but updated for some new changes to dev.

It introduces the :reset slot option, which follows a leftmost-bound inheritance rule and specifies that shared-initialize should ignore its second argument for that slot, always assuming the slot should be initialized.

For weblocks-webapp in particular, it has the problem that for slots provided with :reset t, it would be necessary to export the slot names, so that subclasses could cancel the behavior. It also has the problem that values initialized or normalized by initializer methods are not recognized as reproducible initial values.


(defclass weblocks-webapp-class (standard-class)
()
(:documentation "Class of all classes created by `defwebapp'. The
really interesting behavior is in
`shared-initialize' (weblocks-webapp t &rest)."))

(defmethod validate-superclass ((class weblocks-webapp-class) superclass)
(typep (class-name (class-of superclass))
'(member standard-class weblocks-webapp-class)))

(defgeneric slot-definition-reset-p (slot-defn)
(:documentation "Answer whether to change the value of this slot
when reinitializing or updating an instance after class
redefinition.")
(:method ((slot-defn slot-definition))
"Regardless of this method, only direct-slot-definitions where
`resetp' is a bound slot may participate in the inheritance rule."
nil))

(defgeneric (setf slot-definition-reset-p) (value slot-defn)
(:documentation "See `slot-definition-reset-p'."))

(defclass resetting-slot-definition (slot-definition)
((resetp :initarg :reset :accessor slot-definition-reset-p))
(:documentation "I provide the extension that when `resetp' is
non-nil, and an initarg is not present in the `shared-initialize'
call, I will use a relevant stored initarg or initfunction to reset
my value.

:reset's inheritance rule is leftmost-bound."))

(defclass resetting-eslot-definition
(resetting-slot-definition standard-effective-slot-definition)
())

(defclass resetting-dslot-definition
(resetting-slot-definition standard-direct-slot-definition)
())

(defmethod direct-slot-definition-class
((self weblocks-webapp-class) &rest initargs)
(declare (ignore initargs))
(find-class 'resetting-dslot-definition))

(defmethod effective-slot-definition-class
((self weblocks-webapp-class) &rest initargs)
(declare (ignore initargs))
(find-class 'resetting-eslot-definition))

(defun compute-resetting-eslot-definition (eslot class name dslotds)
"Implement leftmost-bound rule for resetp."
(declare (ignore name))
(setf (slot-definition-reset-p eslot)
(and-let* ((leftmost-bound (find-if (lambda (dslot)
(and (slot-exists-p dslot 'resetp)
(slot-boundp dslot 'resetp)))
dslotds)))
(slot-definition-reset-p leftmost-bound)))
eslot)

(defmethod compute-effective-slot-definition ((self weblocks-webapp-class) name dslotds)
(compute-resetting-eslot-definition (call-next-method) self name dslotds))

(defun reset-slots (instance initargs)
"Given an instance to be initialized and the initargs passed to the
initializer method, reset the appropriate slots to their original
values."
(dolist (eslot (class-slots (class-of instance)))
(when (slot-definition-reset-p eslot)
(let ((initkeys (slot-definition-initargs eslot)))
(when (loop for (key) on initargs by #'cddr
never (member key initkeys))
(flet ((set-it (val)
(setf (slot-value instance (slot-definition-name eslot)) val)))
(or (and-let* (initkeys
(definit
(some (lambda (definit) (member (car definit) initkeys))
(class-default-initargs (class-of instance)))))
(set-it (funcall (third definit)))
t)
(and-let* ((initfunc (slot-definition-initfunction eslot)))
(set-it (funcall initfunc))
t))))))))


Where shared-initialize calls reset-slots when its second argument is not t (as is required for initialize-instance).

Notwithstanding the above issues, the real difficulty forcing me to abandon this particular iteration for now is that the test failures in dev have jumped from 9 (at last pull from c6dc18-test-fixes) to over 90. I'm sure this has to do with the current defwebapp implementation having dependency issues eerily similar to that mentioned in my last post.

By the time I reached this conclusion, I had been too frustrated by fighting with SBCL and SLIME on OS X to do anything about it. Later today, I'll just boot up in GNU/Linux, wifi be damned.

Next up, doing as much as I can without the metaclass, just so other dev writers will put more new instance logic in the initialize method instead of defwebapp. Then I can revisit the metaclass issue with a fresh look, something like this:


(defclass a-class (s-class)
()
(:persistent-initargs :a :b :c)
(:transient-initargs :d :e :f))


…where some initializer method will capture all initargs (not initforms this time, I think), including those given to make-instance, storing in an instvar, and initarg semantics are determined by a leftmost-persistent-or-transient rule. This has the benefit of not killing initializer method settings with the common :initform nil.

Or, I'll be back here later with an explanation of why it won't work.

Wednesday, August 13, 2008

A metaclass for weblocks-webapps, try 2

My next attempt was more interesting, succeeding in point #1, and getting around point #2 with a new slot definition feature.

Unfortunately, at this point, I ran into the default canonicalization behavior for slots and defclass options. While AMOP discusses a possible extension via a generic function canonicalize-defclass-options, it is unfortunately not included in the final MOP. So:


  1. Except for :default-initargs, class options are always quoted.

  2. Except for :initform, slot options are always quoted.



That and a dependency issue forced me to abandon this try, which introduces the instance initfunction to address the common complaint about initforms that the expression cannot refer to the new instance.


(defmacro and-let* ((&rest bindings) &body body)
"Like `let*', but stop when encountering a binding that evaluates to
NIL. Also allows (EXPR), stopping when EXPR is false, and EXPR as a
shortcut for it only if EXPR is a symbol."
(reduce (lambda (binding body)
(etypecase binding
(symbol `(and ,binding ,body))
((cons symbol (cons t null))
`(let (,binding)
(and ,(car binding)
,body)))
((cons t null)
`(and ,(car binding) ,body))))
bindings :from-end t :initial-value (cons 'progn body)))

(defclass weblocks-webapp-class (standard-class)
()
(:documentation "Class of all classes created by `defwebapp'. The
really interesting behavior is in
`shared-initialize' (weblocks-webapp t &rest)."))

(defmethod validate-superclass ((class weblocks-webapp-class) superclass)
(typep (class-name (class-of superclass))
'(member standard-class weblocks-webapp-class)))

(defclass instance-initializing-slot-definition (slot-definition)
((instance-initfunction :initarg :instance-initfunction :initform nil
:accessor slot-definition-instance-initfunction))
(:documentation "I provide an alternative to `:initform' for slots,
the `:instance-initfunction', a function taking the instance to be
initialized."))

(defclass weblocks-webapp-direct-slot-definition
(instance-initializing-slot-definition standard-direct-slot-definition)
()
(:documentation "Direct slot definition for `weblocks-webapp-class'es."))

(defclass weblocks-webapp-effective-slot-definition
(instance-initializing-slot-definition standard-effective-slot-definition)
()
(:documentation "Effective slot definition for `weblocks-webapp-class'es."))

(defmethod compute-effective-slot-definition
((self weblocks-webapp-class) name direct-slot-defns)
"Transfer `instance-initfunction' to the effective slot definition,
making sure to override the regular `initfunction' if mine appears
first in the precedence list, so `shared-initialize' will not call it
to fill the slot."
(let ((eslot (call-next-method)))
(loop for (dslot . slot-precedence) on direct-slot-defns
when (slot-definition-initfunction eslot)
do (return)
when (and (slot-exists-p self 'instance-initfunction)
(slot-definition-instance-initfunction dslot))
do (setf (slot-definition-instance-initfunction eslot)
(slot-definition-instance-initfunction dslot)
(slot-definition-initfunction eslot) nil
(slot-definition-initform eslot) nil)
(return))
eslot))

(defmethod direct-slot-definition-class
((self weblocks-webapp-class) &rest initargs)
"Use my special version when `:instance-initfunction' is present."
(if (getf initargs :instance-initfunction)
(find-class 'weblocks-webapp-direct-slot-definition)
(call-next-method)))

(defmethod effective-slot-definition-class
((self weblocks-webapp-class) &rest initargs)
"As `instance-initfunction' is transferred over later, it isn't
present in INITARGS, so assume any slot might need it."
(declare (ignore initargs))
(find-class 'weblocks-webapp-effective-slot-definition))

(defun instance-initialize-unbound-slots (self slot-names)
"Do the magic promised by `weblocks-webapp-class'."
(let ((slots (class-slots (find-class self))))
(dolist (slot slot-names)
(and-let* (((not (slot-boundp self slot)))
(slotd (find slot slots :key #'slot-definition-name))
(initfunc (slot-definition-instance-initfunction slotd)))
(setf (slot-value self slot)
(funcall initfunc self))))))

(defmethod shared-initialize :after ((self weblocks-webapp-class) slot-names
&key &allow-other-keys)
(declare (ignore slot-names))
(pushnew (class-name self) *registered-webapps*))

(defclass weblocks-webapp ()
((name :accessor weblocks-webapp-name :initarg :name :type string
:instance-initfunction (lambda (self)
(attributize-name (class-name (class-of self)))))
;;snip uninteresting slots
(prefix :accessor weblocks-webapp-prefix :initarg :prefix :initform ""
:instance-initfunction
(lambda (self)
(concatenate 'string "/" (weblocks-webapp-name self)))
:type string
:documentation "The default dispatch will allow a webapp to be invoked
as a subtree of the URI space at this site. This does not support
webapp dispatch on virtual hosts, browser types, etc.")
;;snip more
(init-user-session :accessor weblocks-webapp-init-user-session :initarg :init-user-session
:instance-initfunction
(lambda (self)
(find-symbol (symbol-name '#:init-user-session)
(symbol-package (class-name (class-of self)))))
:type symbol
:documentation "'init-user-session' must be defined by weblocks client in the
same package as 'name'. This function will accept a single parameter - a
composite widget at the root of the application. 'init-user-session' is
responsible for adding initial widgets to this composite.")
(ignore-default-dependencies
:initform nil :initarg :ignore-default-dependencies
:documentation "Inhibit appending the default dependencies to
the dependencies list. By default 'defwebapp' adds the following resources:

Stylesheets: layout.css, main.css
Scripts: prototype.js, weblocks.js, scriptaculous.js")
(debug :accessor weblocks-webapp-debug :initarg :debug :initform nil))
(:metaclass weblocks-webapp-class)
(:documentation "snip"))

(defmacro defwebapp (name &rest initargs &key subclasses slots (autostart t)
&allow-other-keys)
"snip"
(remf initargs :subclasses)
(remf initargs :slots)
(remf initargs :autostart)
`(prog1
(defclass ,name ,(append subclasses (list 'weblocks-webapp))
,slots
(:default-initargs . ,initargs)
(:metaclass weblocks-webapp-class))
(when autostart
(pushnew ',name *autostarting-webapps*))))

(defmethod shared-initialize ((self weblocks-webapp) slot-names
&key &allow-other-keys)
"Use my `instance-initfunction' to initialize any slots that aren't
yet bound."
(instance-initialize-unbound-slots self slot-names)
(macrolet ((do-slot ((bind-var &optional (slot-name bind-var)) &body forms)
`(when (member ',slot-name slot-names)
(let ((,bind-var (slot-value self ',slot-name)))
,@forms))))
(do-slot (init-user-session)
(or init-user-session
(error (format nil "Cannot initialize application ~A because no~
init-user-session function is found."
(webapp-name self)))))
(when (member 'application-dependencies slot-names)
(setf (weblocks-webapp-application-dependencies self)
(build-local-dependencies
(append (and (not (slot-value self 'ignore-default-dependencies))
'((:stylesheet "layout")
(:stylesheet "main")
(:stylesheet "dialog")
(:script "prototype")
(:script "scriptaculous")
(:script "shortcut")
(:script "weblocks")
(:script "dialog")))
dependencies))))
(do-slot (path public-app-path)
(setf (weblocks-webapp-public-app-path self)
(if (or (null path) (eq path :system-default))
nil
(compute-public-files-path
(intern (package-name (class-name (class-of self))) :keyword)))))))


Even without the quoting problem, the fact that prefix's initfunction requires name's initfunction to be called first means that I would need to introduce dependency analysis and expression. But Kenny has already solved this problem.

A metaclass for weblocks-webapps

defwebapp in weblocks-dev currently does many mysterious things with its keyword arguments. But these are the sorts of things that should be given directly to make-instance, so that you can use your own defclass forms and your own make-instance calls to construct weblocks-webapp instances in creative ways.

I have a few goals for a rewrite of defwebapp:

  1. Trivialize the mapping of the defwebapp form to a defclass form, putting most of the logic in initializing methods and possibly a metaclass (ahem, class metaobject class).
  2. Don't hide the default slot values in class-default-initargs.
  3. On reevaluation of defwebapp, replace the slot values, at least in the trivial case where the hacker allowed the normal autostarter to instantiate the resulting weblocks-webapp subclass.


My first thought, abandoned before I could even start changing defwebapp proper to use it, would have defwebapp fill class-instance slots (not to be confused with instance slots with :allocation :class) instead of default-initargs, then alter the initform and initfunction in compute-effective-slot-definition to copy over those values to each new instance.


(defclass weblocks-webapp-class (standard-class)
())

(defmethod validate-superclass ((class weblocks-webapp-class) superclass)
(typep (class-name (class-of superclass))
'(member standard-class weblocks-webapp-class)))

(defgeneric class-defaulting-slots (class)
(:method ((self weblocks-webapp-class))
(loop for class in (class-precedence-list self)
while (typep class 'weblocks-webapp-class)
append (class-direct-slots class)))
(:method ((self standard-class)) '()))

(defmethod compute-effective-slot-definition
((self weblocks-webapp-class) name direct-slot-defns)
"Provide a default initform (read the class's version of the slot)
for those without initforms."
(let ((eslot (call-next-method))
(defaulting-slots (class-defaulting-slots self)))
(macrolet ((initfunc () (slot-definition-initfunction eslot)))
(when (and (find name defaulting-slots :key #'slot-definition-name)
(not (initfunc)))
(setf (slot-definition-initform eslot)
`(slot-value (find-class ',(class-name self)) ',name)
(initfunc) (lambda () (slot-value self name)))))
eslot))