guile-compensation

Using compensation stacks with Guile

by uriel.

The code in this page presents a Guile module that implements compensation stacks: syntactic sugar that allows us to write code that allocates a resource near the code that releases it in case of error.

Compensation stacks are described in ''Finding and Preventing Run-Time Error Handling Mistakes'', Weimer and Necula (1), (URL last verified on Wed May 2, 2007).

(1) http://www.cs.virginia.edu/~weimer/papers/WN-FindingAndPreventing.pdf

In this document's jargon: a compensation is a chunk of code that undoes a resource allocation performed in another chunk, example: 

 (define port (open-file "/tmp/proof.1" "w+"))

must be compensated by: 

 (close-port port)

Compensation forms are embedded in a closure and pushed on a stack, so that, in case of error, it is possible to evaluate them in allocation-reversed order.

Basic compensations usage

A form that makes use of a compensations stack looks like this: 

 (with-compensations 
   (compensate 
       ALLOC-FORMS-1 
     (with COMP-FORMS-1))  
   (compensate 
       ALLOC-FORMS-2 
     (with COMP-FORMS-2))  
   BODY-FORMS)

both with-compensations and compensate are macros; to gain a little execution speed we accept code duplication in their expansion.

with-compensation does not invokes the compensations before returning, but it is possible to do it by explicitly invoking the compensations function.

Another useful form is: 

 (let-compensations* ((a (compensate 
                             ALLOC-FORMS-1 
                           (with COMP-FORMS-1))) 
                      (b (compensate 
                             ALLOC-FORMS-2 
                           (with COMP-FORMS-2)))) 
   BODY-FORMS)

in which the return value of the ALLOC-FORMS is stored in local bindings; if no error occurs: before returning let-compensations* invokes all the compensation closures in reversed order.

Handling the stack

with-compensations makes use of a fluid to instantiate a new compensations stack and embeds all its arguments in the body of a catch form; the following: 

 (with-compensations FORMS)

expands to: 

 (with-fluid *compensations* '() 
   (catch #t 
     (lambda () FORMS) 
     (lambda (key . args) 
        (for-each (lambda (closure) (false-if-exception (closure))) 
                  (fluid-ref *compensations*)) 
        (apply throw key args))))

we see that:

  1. the compensation closures are wrapped in false-if-exception: this causes errors to be ignored and all the closures to be evaluated;
  2. after the evaluation of the closures, the exception is rethrown;
  3. if no error occurs, the closures are not invoked.

Handling compensations

A compensate form like: 

 (compensate 
     ALLOC-FORMS 
   (with COMP-FORMS))

is expanded to: 

 (let ((<symbol> (begin ALLOC-FORMS))) 
   (fluid-set! *compensations* 
               (cons (lambda () COMP-FORMS) 
                     (fluid-ref *compensations*))) 
   <symbol>)

that is:

  1. the allocation forms are evaluated;
  2. a closure with the compensation forms is pushed on the current stack;
  3. the value of ALLOC-FORMS is returned;
  4. if an exception is thrown in ALLOC-FORMS the compensation is not pushed.

Local bindings

A form like: 

 (let-compensations* ((a (compensate 
                             ALLOC-FORMS-1 
                           (with COMP-FORMS-1))) 
                      (b (compensate 
                             ALLOC-FORMS-2 
                           (with COMP-FORMS-2)))) 
   BODY-FORMS)

is expanded to: 

 (with-compensations 
    (let* ((a #f) 
           (b #f)) 
      (set! a (compensate 
                   ALLOC-FORMS-1 
                (with COMP-FORMS-1))) 
      (set! b (compensate 
                   ALLOC-FORMS-2 
                (with COMP-FORMS-2))) 
      (let ((<symbol> (begin BODY-FORMS))) 
        (compensations) 
        <symbol>)))

that is:

  1. all the local variables are created first, so that they are available to the closures;
  2. all the compensations are evaluated;
  3. after the BODY-FORMS have been evaluated without errors, compensations evaluates all the closures to release the resources;
  4. the return value is the return value of BODY-FORMS.

The module 

 (define-module (compensations) 
   #:export (*compensations* with-compensations let-compensations* 
                             compensate compensations)) 
  
  
 (define *compensations* (make-fluid)) 
  
 (define (compensations) 
   (for-each (lambda (closure) (false-if-exception (closure))) 
             (fluid-ref *compensations*))) 
  
 (define-macro (with-compensations . FORMS) 
   `(with-fluid* *compensations* '() 
                 (lambda () 
                   (catch #t 
                     (lambda () ,@FORMS) 
                     (lambda (key . args) 
                       (for-each (lambda (closure) (false-if-exception (closure))) 
                                 (fluid-ref *compensations*)) 
                       (apply throw key args)))))) 
  
 (define-macro (let-compensations* bindings . FORMS) 
   (if (null? bindings) 
       `(let () ,@FORMS) 
       (let ((BINDINGS '()) 
             (COMPS '()) 
             (RESULT (make-symbol "let-result"))) 
         (for-each (lambda (ell) 
                     (set! BINDINGS (append BINDINGS (list (list (car ell) #f)))) 
                     (set! COMPS    (append COMPS 
                                            (list (list 'set! (car ell) (cadr ell)))))) 
                   bindings) 
         `(with-compensations 
           (let* ,BINDINGS 
             ,@COMPS 
             (let ((,RESULT (begin ,@FORMS))) 
               (compensations) 
               ,RESULT)))))) 
  
 (define-macro (compensate . args) 
   (let* ((rargs         (reverse args)) 
          (with-form     (car rargs)) 
          (ALLOC-FORMS   (reverse (cdr rargs))) 
          (RESULT        (make-symbol "compensate-result"))) 
     (if (not (eq? 'with (car with-form))) 
         (scm-error 'wrong-type-arg 'compensate 
                    "expected 'with' form got: ~A" (list with-form) #f)) 
     `(let ((,RESULT (begin 
                       ,@ALLOC-FORMS))) 
        (fluid-set! *compensations* 
                    (cons (lambda () 
                            ,@(cdr with-form)) 
                          (fluid-ref *compensations*))) 
        ,RESULT)))

Test code

If we save the current directory both the module file, compensations.scm, and the test file compensations-tests.scm: the tests can be executed with the shell command: 

$ GUILE_LOAD_PATH=${PWD} guile -s compensations-tests.scm

 ;;; compensations-test.scm -- 
  
 (use-modules (compensations)) 
  
 ;; ------------------------------------------------------------ 
  
 (define-macro (test DESCR FORM) 
   `(begin 
      (format #t "~%* ~A:~%~%" ,DESCR) 
      (catch #t 
        (lambda () ,FORM) 
        (lambda (key . args) 
          (format (current-error-port) "catched error key: ~A~%" key))))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "No error" 
       (with-compensations 
        (compensate 
            (format #t "allocation 1~%") 
            (+ 1 2) 
          (with 
           (format #t "compensation 1~%"))) 
        (compensate 
            (format #t "allocation 2~%") 
            (+ 3 4) 
          (with 
           (format #t "compensation 2~%"))) 
        (format #t "Ciao!~%") 
        (compensate 
            (format #t "allocation 3~%") 
            (+ 5 6) 
          (with 
           (format #t "compensation 3~%"))) 
        (format #t "Ciao!~%") 
        (format #t "Ciao!~%"))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "No error, explicit compensations invocation" 
       (with-compensations 
        (compensate 
            (format #t "allocation 1~%") 
            (+ 1 2) 
          (with 
           (format #t "compensation 1~%"))) 
        (compensate 
            (format #t "allocation 2~%") 
            (+ 3 4) 
          (with 
           (format #t "compensation 2~%"))) 
        (format #t "Ciao!~%") 
        (compensate 
            (format #t "allocation 3~%") 
            (+ 5 6) 
          (with 
           (format #t "compensation 3~%"))) 
        (format #t "Ciao!~%") 
        (format #t "running compensations...~%") 
        (compensations))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "Error in the body" 
       (with-compensations 
        (compensate 
            (format #t "allocation 1~%") 
            (+ 1 2) 
          (with 
           (format #t "compensation 1~%"))) 
        (compensate 
            (format #t "allocation 2~%") 
            (+ 3 4) 
          (with 
           (format #t "compensation 2~%"))) 
        (format #t "throwing from body...~%") 
        (throw 'misc-error))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "Error in resource allocation" 
       (with-compensations 
        (compensate 
            (format #t "allocation 1~%") 
            (+ 1 2) 
          (with 
           (format #t "compensation 1~%"))) 
        (compensate 
            (format #t "throwing from allocation 2...~%") 
            (throw 'misc-error) 
          (with 
           (format #t "compensation 2~%"))) 
        (compensate 
            (format #t "allocation 3~%") 
            (+ 5 6) 
          (with 
           (format #t "compensation 3~%"))) 
        (format #t "Ciao!~%"))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "Throwing from the body and error in compensation form" 
       (with-compensations 
        (compensate 
            (format #t "allocation 1~%") 
            (+ 1 2) 
          (with 
           (format #t "compensation 1~%"))) 
        (compensate 
            (format #t "allocation 2~%") 
            (+ 3 4) 
          (with 
           (format #t "throwing from compensation 2...~%") 
           (throw 'nested-error))) 
        (compensate 
            (format #t "allocation 3~%") 
            (+ 5 6) 
          (with 
           (format #t "compensation 3~%"))) 
        (format #t "throwing from body...~%") 
        (throw 'misc-error))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "Let, no error" 
       (let-compensations* ((a (compensate 
                                  (format #t "allocation 1~%") 
                                  (+ 1 2) 
                                (with 
                                 (format #t "compensation 1~%")))) 
                           (b (compensate 
                                  (format #t "allocation 2~%") 
                                  (+ 3 4) 
                                (with 
                                 (format #t "compensation 2~%"))))) 
                          (format #t "Ciao!~%") 
                          (compensate 
                              (format #t "allocation 3~%") 
                              (+ 5 6) 
                            (with 
                             (format #t "compensation 3~%"))) 
                          (format #t "Ciao!~%") 
                          (format #t "Ciao!~%"))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "Let, no error" 
       (let-compensations* ((a (compensate 
                               (format #t "allocation 1~%") 
                               (+ 1 2) 
                               (with 
                                (format #t "compensation 1~%")))) 
                           (b (compensate 
                               (format #t "allocation 2~%") 
                               (+ 3 4) 
                               (with 
                                (format #t "compensation 2~%"))))) 
                          (format #t "Ciao!~%") 
                          (compensate 
                           (format #t "allocation 3~%") 
                           (+ 5 6) 
                           (with 
                            (format #t "compensation 3~%"))) 
                          (format #t "Ciao!~%") 
                          (format #t "running compensations...~%"))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "Error in the body" 
       (let-compensations* ((a (compensate 
                               (format #t "allocation 1~%") 
                               (+ 1 2) 
                               (with 
                                (format #t "compensation 1~%")))) 
                           (b (compensate 
                               (format #t "allocation 2~%") 
                               (+ 3 4) 
                               (with 
                                (format #t "compensation 2~%"))))) 
                          (format #t "throwing from body...~%") 
                          (throw 'misc-error))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "Error in resource allocation" 
       (let-compensations* ((a (compensate 
                               (format #t "allocation 1~%") 
                               (+ 1 2) 
                               (with 
                                (format #t "compensation 1~%")))) 
                           (b (compensate 
                               (format #t "throwing from allocation 2...~%") 
                               (throw 'misc-error) 
                               (with 
                                (format #t "compensation 2~%")))) 
                           (c (compensate 
                               (format #t "allocation 3~%") 
                               (+ 5 6) 
                               (with 
                                (format #t "compensation 3~%"))))) 
                          (format #t "Ciao!~%"))) 
  
 ;; ------------------------------------------------------------ 
  
 (test "Throwing from the body and error in compensation form" 
       (let-compensations* ((a (compensate 
                               (format #t "allocation 1~%") 
                               (+ 1 2) 
                               (with 
                                (format #t "compensation 1~%")))) 
                           (b (compensate 
                               (format #t "allocation 2~%") 
                               (+ 3 4) 
                               (with 
                                (format #t "throwing from compensation 2...~%") 
                                (throw 'nested-error)))) 
                           (c (compensate 
                               (format #t "allocation 3~%") 
                               (+ 5 6) 
                               (with 
                                (format #t "compensation 3~%"))))) 
                          (format #t "throwing from body...~%") 
                          (throw 'misc-error))) 
  
 (test "Let, bindings" 
       (let-compensations* ((a (compensate 
                                (format #t "allocation 1~%") 
                                (+ 1 2) 
                                (with 
                                 (format #t "compensating 1: ~A~%" a)))) 
                            (b (compensate 
                                (format #t "allocation 2~%") 
                                (+ 3 4) 
                                (with 
                                 (format #t "compensating 2: ~A~%" b))))) 
                           (format #t "throwing from body...~%") 
                           (throw 'this-error))) 
  
 ;;; end of file

category-guile

Last modified : 2015-10-10 04:46:17
WiLiKi 0.5-tekili-7 running on Gauche 0.9