r1611: *** empty log message ***

diff --git a/ChangeLog b/ChangeLog
index 8e4c6a0e1a34b48e59430529b58c161ef87c4c0f..56c0d7d71556d26af26448968cb85ef79f80e8da 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -12,6 +12,7 @@ See TODO file -- actively maintained. Includes changes that you
        * Added ensure-char-* and def-union to documentation
        * Added double-float vector example to c-test-fns
        * Reworked cstring on Lispworks to have LW handle string conversion
+       * First pass at with-foreign-object -- untested/unoptimized
        
 20 Mar 2002
        * Updated strings.cl so that foreign-strings are always unsigned.

diff --git a/Makefile b/Makefile
index 8191f53ef19f927f8490db8b6859592836b95fd2..6be1b72e0ce309a28bc23496fad402e696b8889e 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -5,7 +5,7 @@
 #  Programer:    Kevin M. Rosenberg, M.D.
 #  Date Started: Mar 2002
 #
-#  CVS Id:   $Id: Makefile,v 1.26 2002/03/21 07:56:45 kevin Exp $
+#  CVS Id:   $Id: Makefile,v 1.27 2002/03/21 14:49:14 kevin Exp $
 #
 # This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 #
@@ -36,7 +36,8 @@ DISTDIR=uffi-${VERSION}
 DIST_TARBALL=${DISTDIR}.tar.gz
 DIST_ZIP=${DISTDIR}.zip
 SOURCE_FILES=src doc examples Makefile uffi.system COPYRIGHT README TODO \
-        INSTALL uffi.lsm ChangeLog NEWS test-examples.cl set-logical.cl
+        INSTALL uffi.lsm ChangeLog NEWS test-examples.cl set-logical.cl \
+       benchmarks
 
 dist: realclean docs
        @rm -fr ${DISTDIR} ${DIST_TARBALL} ${DIST_ZIP}

diff --git a/benchmarks/allocation.cl b/benchmarks/allocation.cl
index de014f729b706720cdd7aab4b9c1113f2a5f4245..6be7bf9a9558b03db6aa2141726ffd1a2e3353d4 100644 (file)
--- a/benchmarks/allocation.cl
+++ b/benchmarks/allocation.cl
@@ -1,7 +1,26 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          allocation.cl
+;;;; Purpose:       Benchmark allocation and slot-access speed
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: allocation.cl,v 1.2 2002/03/21 14:49:14 kevin Exp $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; UFFI users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
 (in-package :cl-user)
 
 
-(defun stk ()
+(defun stk-int ()
   #+allegro
   (ff:with-stack-fobject (ptr :int) 
     (setf (ff:fslot-value ptr) 0))
@@ -13,7 +32,19 @@
     (setf ptr 0))
   )
 
-(defun stat ()
+(defun stk-vector ()
+  #+allegro
+  (ff:with-stack-fobject (ptr '(:array :int 10) )
+    (setf (ff:fslot-value ptr 5) 0))
+  #+lispworks
+  (fli:with-dynamic-foreign-objects ((ptr (:c-array :int 10)))
+    (setf (fli:dereference ptr 5) 0))
+  #+cmu
+  (alien:with-alien ((ptr (alien:array alien:signed 10)))
+    (setf (alien:deref ptr 5) 0))
+  )
+
+(defun stat-int ()
   #+allegro
   (let ((ptr (ff:allocate-fobject :int :c)))
     (declare (dynamic-extent ptr))
@@ -32,17 +63,45 @@
     (alien:free-alien ptr))
   )
 
+(defun stat-vector ()
+  #+allegro
+  (let ((ptr (ff:allocate-fobject '(:array :int 10) :c)))
+    (declare (dynamic-extent ptr))
+    (setf (ff:fslot-value-typed '(:array :int 10) :c ptr 5) 0)
+    (ff:free-fobject ptr))
+  #+lispworks
+  (let ((ptr (fli:allocate-foreign-object :type '(:c-array :int 10))))
+    (declare (dynamic-extent ptr))
+    (setf (fli:dereference ptr 5) 0)
+    (fli:free-foreign-object ptr))
+  #+cmu
+  (let ((ptr (alien:make-alien (alien:array (alien:signed 32) 10))))
+    (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+            (dynamic-extent ptr))
+    (setf (alien:deref ptr 5) 0)
+    (alien:free-alien ptr))
+  )
 
 
 (defun stk-vs-stat ()
-  (format t "~&Stack allocation")
+  (format t "~&Stack allocation, Integer")
   (time (dotimes (i 1000) 
          (dotimes (j 1000)
-           (stk))))
-  (format t "~&Static allocation, open-coded slot access")
+           (stk-int))))
+  (format t "~&Static allocation, Integer")
   (time (dotimes (i 1000) 
          (dotimes (j 1000)
-           (stat)))))
+           (stat-int))))
+  (format t "~&Stack allocation, Vector")
+  (time (dotimes (i 1000) 
+         (dotimes (j 1000)
+           (stk-int))))
+  (format t "~&Static allocation, Vector")
+  (time (dotimes (i 1000) 
+         (dotimes (j 1000)
+           (stat-int))))
+)
+
 
                            
 

diff --git a/src/objects.cl b/src/objects.cl
index 1ac0ad8b4080f6c1836a10b69eb447d2be3b9693..b0b34f07ca98fb8191238cdf7f9fd8e5285c24eb 100644 (file)
--- a/src/objects.cl
+++ b/src/objects.cl
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: objects.cl,v 1.10 2002/03/21 07:56:45 kevin Exp $
+;;;; $Id: objects.cl,v 1.11 2002/03/21 14:49:14 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -100,19 +100,21 @@ an array of TYPE with size SIZE."
   obj
   )
 
-#|
-(defmacro allocate-byte-array (nsize)
-  #+cmu
-  `(alien:make-alien (alien:unsigned 8) ,nsize)
-  #+lispworks
-  `(fli:allocate-foreign-object :type :byte :nelems ,nsize)
-  #+allegro
-  `(ff:allocate-fobject (array :byte ,nsize))
-)
+;; Simple first pass. Will later create optimized routines for
+;; various platforms.
+(defmacro with-foreign-object ((var type &rest etc) &rest body)
+  (let ((result (gensym)))
+    `(let* ((,var (allocate-foreign-object ,type ,@etc))
+           (,result (progn ,@body)))
+      (free-foreign-object ,var)
+      ,result)))
 
-(defmacro deref-byte-array (array position)
-  #+cmu `(alien:deref ,array ,position)
-  #+lispworks `(fli:dereference ,array :index ,position)
-  #+allegro `(ff:fslot-value-typed '(:array :byte) :c ,array ,position)
-)
-|#
+(defmacro with-foreign-objects (bindings &rest body)
+  (if bindings
+      `(with-foreign-object ,(car bindings)
+       (with-foreign-objects ,(cdr bindings)
+         ,@body))
+      `(progn ,@body)))
+
+           
+