s c h e m a t i c s : c o o k b o o k

/ Cookbook.PLTCustodianRegistration

This Web


WebHome 
WebChanges 
TOC (with recipes)
NewRecipe 
WebTopicList 
WebStatistics 

Other Webs


Chicken
Cookbook
Erlang
Know
Main
Plugins
Sandbox
Scm
TWiki  

Schematics


Schematics Home
Sourceforge Page
SchemeWiki.org
Original Cookbook
RSS

Scheme Links


Schemers.org
Scheme FAQ
R5RS
SRFIs
Scheme Cross Reference
PLT Scheme SISC
Scheme48 SCM
MIT Scheme scsh
JScheme Kawa
Chicken Guile
Bigloo Tiny
Gambit LispMe
GaucheChez

Lambda the Ultimate
TWiki.org

Registering an object to a custodian

Problem

The foreign function interface allows us to register objects with a finalizer that calls when an object is about to be GC-ed. However, there are certain resources that we'd like to reclaim in a controlled way, without having to wait for the GC. PLT Scheme provides custodians to do this resource management. This module includes a nice register-custodian primitive that's similar to register-finalizer.

Solution

(module custodian-util mzscheme
  (require (lib "foreign.ss"))
  (require (lib "list.ss"))
  (require (prefix lowlevel: #%foreign))
  (require (prefix c: (lib "contract.ss")))
  (unsafe!)

  ;; FIXME: add the proper contract to register-custodian.  From notes in the thread:
  ;;
  ;; http://list.cs.brown.edu/pipermail/plt-scheme/2005-September/009746.html
  ;;
  ;; it sounds like getting the proper polymorphic contract is
  ;; slightly harder than I thought, so I'll be a bit loose here.
  ;; I'll need to read more about contracts before I dive into this
  ;; further.
  (c:provide/contract
   (register-custodian (c:any/c c:any/c string? string? . c:-> . void?)))

                    
  ;; Get at the currently running mzscheme process.
  (define self-lib.so (ffi-lib #f))

  ;; Checks to see if the custodian's still alive.  Raises an error if
  ;; the custodian's already done for.
  (define custodian-check-available
    (get-ffi-obj "scheme_custodian_check_available" self-lib.so
                 (_fun _pointer _string _string -> _void)))

  ;; Adds a callback function to an object that's about to be
  ;; terminated by a custodian.
  (define custodian-add-managed
    (get-ffi-obj "scheme_add_managed" self-lib.so
                 (_fun _pointer _scheme _fpointer _pointer _int -> _pointer)))
  
  ;; Builds a low-level C-callable function ready to be passed as a
  ;; _fpointer to custodian-add-managed.  Don't forget to hold a
  ;; reference to this callback somewhere so it doesn't get GC'ed.
  (define (make-custodian-callback f)
    (lowlevel:ffi-callback f (list _scheme _pointer) _pointer))

  
  ;; register-custodian: A (A -> void) string string -> void
  ;;
  ;; Registers an object to a shutdown procedure with the
  ;; current-custodian.  If an error occurs during registration,
  ;; raises an error with name and resname.
  (define register-custodian
    (let* ((registered-finalizers '())
           (add-registered-finalizer!
            (lambda (f) (set! registered-finalizers (cons f registered-finalizers))))
           (remove-registered-finalizer!
            (lambda (f) (set! registered-finalizers (remove f registered-finalizers)))))
      (lambda (object finalizer name resname)
        (let*
            ((callback-box (box #f))
             (wrapped-finalizer (lambda (o)
                                  (remove-registered-finalizer! (unbox callback-box))
                                  (finalizer o))))
          ;; fixme: what happens if current-custodian gets killed here
          ;; before we get to register finalizers?  Low-level race
          ;; condition?
          (let ((callback-val
                 (attach-to-current-custodian object wrapped-finalizer name resname)))
            (set-box! callback-box callback-val)
            (add-registered-finalizer! callback-val))))))
  

  ;; attach-to-current-custodian: A (A -> void) string string -> callback
  ;; Associates the object to the current-custodian.  When the custodian
  ;; shuts down, the shutdown-f is called.
  ;;
  ;; Returns the C callback that will be called when
  ;; custodian-shutdown-all is called.  Danger: there aren't any hard
  ;; references to this callback, so callers of this function must be
  ;; careful to make sure this value isn't GC-ed before the custodian
  ;; runs.
  ;;
  ;; name and resname are the arguments passed to
  ;; scheme_check_available for error checking; see
  ;; http://download.plt-scheme.org/doc/299.400/html/insidemz/insidemz-Z-H-16.html#node_chap_16
  (define (attach-to-current-custodian object shutdown-f name resname)
    (let ((callback (make-custodian-callback
                     (lambda (obj _)
                       (shutdown-f obj)
                       #f))))
      ;; Attach to the current-custodian
      (custodian-check-available #f name resname)
      (custodian-add-managed #f object callback #f 0)
      callback)))

Discussion

Example test usage:

(require "custodian-util.ss")
(require (lib "foreign.ss"))
(unsafe!)
(define self-lib.so (ffi-lib #f))
(define fopen (get-ffi-obj "fopen" self-lib.so (_fun _string _string -> _pointer)))
(define fclose (get-ffi-obj "fclose" self-lib.so (_fun _pointer -> _int)))
(let loop ()
  (parameterize ((current-custodian (make-custodian)))
    (let ((file (fopen "/etc/passwd" "r")))
      (register-custodian file fclose "fopen" "io")
      (custodian-shutdown-all (current-custodian))))
  (loop))


Comments about this recipe

Contributors

-- DannyYoo - 03 Oct 2005

CookbookForm
TopicType: Recipe
ParentTopic: ForeignInterfaceRecipes
TopicOrder: 999

 
 
Copyright © 2004 by the contributing authors. All material on the Schematics Cookbook web site is the property of the contributing authors.
The copyright for certain compilations of material taken from this website is held by the SchematicsEditorsGroup - see ContributorAgreement & LGPL.
Other than such compilations, this material can be redistributed and/or modified under the terms of the GNU Lesser General Public License (LGPL), version 2.1, as published by the Free Software Foundation.
Ideas, requests, problems regarding Schematics Cookbook? Send feedback.
/ You are Main.guest