Subject: [clisp-list] FFI: :malloc-free allocation (was: FFI guru/wizard award to be re warded)

From: "Hoehle, Joerg-Cyril" <[email-masked]>
Date: Mon Apr 7 09:10:03 2003

Hi,

FFI has had :malloc-free allocation since ever. It would be unfortunate if it would not work with Berkely DB. Let's see.

Aurelio Bignoli wrote:
>I'm trying to interface Berkeley DB C API
>(http://www.sleepycat.com). It uses "Data Base Thangs" to read and
>write data to/from DB files:

I went to consult their doc and found:
http://www.sleepycat.com/docs/index.html
http://www.sleepycat.com/docs/api_java/c_index.html

(def-c-struct DBT
  (data c-string) ;; truly a polymorphic pointer type
  (size uint32)
  (ulen uint32) (dlen uint32) (doff uint32) (flags uint32))

One problem I see is that CLISP's FFI has :malloc-free allocation on a per parameter basis. Here it looks like one would wish for it on a per-pointer basis,e.g.
 (c-ptr :alloca
   DBT  :malloc-free)

So how can we mix that?
I'll talk about the 100% solution later. Here comes a solution that should work in current CLISP.

We're going to use DEF-C-VAR with :alloc :malloc-free. The variable itself will not be freed, yet some of its pointers may.

(def-c-var DBT-pool (:type (c-array DBT 10))
  (:name "DBT_pool") (:alloc :malloc-free))

Using (setf (slot (element DBT-pool 0) 'data) "foobar")
invokes malloc(). We can free() that memory using
(setf (slot (element DBT-pool pool-index) 'data) nil)

This can be used together with both Bekerley DB's free and realloc flags.

This yields to the following schema:
(def-call-out DB-get
  (:arguments (key c-pointer))
  (:return-type ...)
  (:language :stdc))

(defun get-as-string (pool-index)
  (prog1
      (values
       (DB-get (c-var-address (element DBT-pool pool-index)))
       ;;TODO error checking
       (slot (element DBT-pool pool-index) 'data))
    ;; setting to NIL frees memory
    (setf (slot (element DBT-pool pool-index) 'data) nil)))

We will use the fact that free() can be called on anything:
(get-using-c-type (pool-index c-type)
  (prog1
      (values
       (DB-get (c-var-address (element DBT-pool pool-index)))
       ;;TODO error checking
       ;;uhoh, run-time parse-c-type...
       (cast (slot (element DBT-pool pool-index) 'data) c-type))
    (setf (slot (element DBT-pool pool-index) 'data) nil)))
;(get-using-c-type 0 `(c-ptr (c-array uint ,size)))

On symbol-macros vs. foreign-variable objects

Here (slot (element- ...)) is recomputed each and multiple times. If we could use the underlying foreign-variable objects instead of the symbol macros, we could use memoization and other speed up techniques.
We'd keep a pool of 10 DBT represented as foreign-variable objects. We could keep a memoized set of foreign-variables, each corresponding to a specific data type, for each DBT.

That's also a value of making foreign-variable objects go public. Places are nice, however Lisp (and Smalltalk) programmers know how to manipulate objects.

On creating and using foreign-objects dynamically instead of the def-c-var trick
More on this another time. Time is running out on me.

Regards,
	Jorg Hohle.

---

From: Aurelio Bignoli <[email-masked]>
Date: Tue Apr 8 13:18:05 2003

> (setf (slot (element DBT-pool pool-index) 'data) nil)

really interesting! I wasn't aware of this feature.

 > On creating and using foreign-objects dynamically instead of the

I used this approach. I wrote the following macro:

(defmacro with-dbt ((dbt value) &body body)
  (let ((val (gensym))
        (data (gensym ))
        (foreign-type-decl (gensym))
        (foreign-length (gensym)))
    `(let ((,val ,value)
           (,dbt (make-dbt :ulen 0 :dlen 0 :doff 0 :flags 0)))
       (multiple-value-bind (,foreign-type-decl ,foreign-length)
           (make-foreign-type-decl ,val)
         (with-c-var (,data  ,foreign-type-decl ,val)
            (setf (dbt-data ,dbt) (c-var-address ,data))
            (setf (dbt-size ,dbt) ,foreign-length)
            ,@body)))))

(in my definition of DBT, data is a c-pointer). Polymorphism is
managed by MAKE-FOREIGN-TYPE-DECL, a generic functions which dispatch
on the type of its argument:

(defmethod make-foreign-type-decl ((value integer))
  (typecase value
    (fixnum (values 'int sizeof-int))
    (otherwise (signal-db-error (format nil "Integer type ~A not supported"
                                        (type-of value))))))

(defmethod make-foreign-type-decl ((value string))
  (let ((l (length value)))
    (values `(c-array character ,l) l)))

etc.

I also wrote a thin C wrapper around DB functions, since it is almost
impossible to use DB structure and its function pointers from Lisp:

(def-c-type DB c-pointer)
(def-c-type DB-TXN c-pointer)

(def-call-out ffi-db-get
  (:name "db_get")
  (:arguments  (db DB :in) (txn DB-TXN :in) (key (c-ptr DBT) :in)
               (data (c-ptr DBT) :out) (flags uint32 :in))
  (:return-type int))

int 
db_get (DB *dbp, DB_TXN *txnid, DBT *key, DBT *data, u_int32_t flags)
{
  int r;
  
  db_log (3, "db_get: dbp = %p, txnid = %p, key = %p, data = %p, "
          "flags = %u", dbp, txnid, key, data, flags);
  data->flags = DB_DBT_MALLOC;
  r = dbp->get (dbp, txnid, key, data, flags);
  dbFuncLog (db->get, r);
  return r;
}

My Lisp version of DB->get:

(defun db-get (key &key (db *default-db*) (txn *default-txn*) (flags 0) 
                   (data-type '(unsigned-byte 8)))
  "Retrieves key/data pairs from database."
  (if (valid-data-type-p data-type)
    (with-dbt (key-dbt key)
      (multiple-value-bind (r data)
          (ffi-db-get (foreign-object-address db) (foreign-object-address txn)
                      key-dbt flags)
        (unwind-protect
            (cond
             ;; Success, key found.
             ((= r 0) (values r
                              (get-foreign-data (dbt-data data)
                                                (dbt-size data) data-type)))
             ;; Success, key not found.
             ((not-found-error-p r)  (values r nil))
             ;; Error.
             (t (signal-db-error "db-get" r)))
          ;; Free DBT data.
          (linux:free (dbt-data data)))))
    (signal-db-error (format nil "Invalid data type: ~A" data-type))))

IMHO, this solution is quite simple and intuitive. Probably
performances can be improved, but for my needs they are accetable.