r2912: rename .cl to .lisp

[uffi.git] / benchmarks / allocation.lisp

diff --git a/benchmarks/allocation.lisp b/benchmarks/allocation.lisp
new file mode 100644 (file)
index 0000000..516902a
--- /dev/null
+++ b/benchmarks/allocation.lisp
@@ -0,0 +1,110 @@
+;;;; -*- 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.lisp,v 1.1 2002/09/30 10:02:36 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-int ()
+  #+allegro
+  (ff:with-stack-fobject (ptr :int) 
+    (setf (ff:fslot-value ptr) 0))
+  #+lispworks
+  (fli:with-dynamic-foreign-objects ((ptr :int))
+    (setf (fli:dereference ptr) 0))
+  #+cmu
+  (alien:with-alien ((ptr alien:signed))
+    (let ((p (alien:addr ptr)))
+      (setf (alien:deref p) 0)))
+  )
+
+(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))
+    (setf (ff:fslot-value-typed :int :c ptr) 0)
+    (ff:free-fobject ptr))
+  #+lispworks
+  (let ((ptr (fli:allocate-foreign-object :type :int)))
+    (declare (dynamic-extent ptr))
+    (setf (fli:dereference ptr) 0)
+    (fli:free-foreign-object ptr))
+  #+cmu
+  (let ((ptr (alien:make-alien (alien:signed 32))))
+    (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+            (dynamic-extent ptr))
+    (setf (alien:deref ptr) 0)
+    (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, Integer")
+  (time (dotimes (i 1000) 
+         (dotimes (j 1000)
+           (stk-int))))
+  (format t "~&Static allocation, Integer")
+  (time (dotimes (i 1000) 
+         (dotimes (j 1000)
+           (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))))
+)
+
+
+(stk-vs-stat)
+
+                           
+