From: Kevin M. Rosenberg Date: Thu, 21 Mar 2002 14:49:14 +0000 (+0000) Subject: r1611: *** empty log message *** X-Git-Tag: v1.6.1~556 X-Git-Url: http://git.kpe.io/?a=commitdiff_plain;ds=sidebyside;h=4054fe997dbce15071a1d2b96a082b4a4a5a8363;p=uffi.git r1611: *** empty log message *** --- diff --git a/ChangeLog b/ChangeLog index 8e4c6a0..56c0d7d 100644 --- 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 8191f53..6be1b72 100644 --- 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 de014f7..6be7bf9 100644 --- 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 1ac0ad8..b0b34f0 100644 --- 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))) + + +