benchmarks/allocation.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          allocation.cl
   6 ;;;; Purpose:       Benchmark allocation and slot-access speed
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Mar 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; UFFI users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  20 (in-package :cl-user)
  21
  22
  23 (defun stk-int ()
  24   #+allegro
  25   (ff:with-stack-fobject (ptr :int)
  26     (setf (ff:fslot-value ptr) 0))
  27   #+lispworks
  28   (fli:with-dynamic-foreign-objects ((ptr :int))
  29     (setf (fli:dereference ptr) 0))
  30   #+cmu
  31   (alien:with-alien ((ptr alien:signed))
  32     (let ((p (alien:addr ptr)))
  33       (setf (alien:deref p) 0)))
  34   #+sbcl
  35   (sb-alien:with-alien ((ptr sb-alien:signed))
  36     (let ((p (sb-alien:addr ptr)))
  37       (setf (sb-alien:deref p) 0)))
  38   )
  39
  40 (defun stk-vector ()
  41   #+allegro
  42   (ff:with-stack-fobject (ptr '(:array :int 10) )
  43     (setf (ff:fslot-value ptr 5) 0))
  44   #+lispworks
  45   (fli:with-dynamic-foreign-objects ((ptr (:c-array :int 10)))
  46     (setf (fli:dereference ptr 5) 0))
  47   #+cmu
  48   (alien:with-alien ((ptr (alien:array alien:signed 10)))
  49     (setf (alien:deref ptr 5) 0))
  50   #+sbcl
  51   (sb-alien:with-alien ((ptr (sb-alien:array sb-alien:signed 10)))
  52     (setf (sb-alien:deref ptr 5) 0))
  53   )
  54
  55 (defun stat-int ()
  56   #+allegro
  57   (let ((ptr (ff:allocate-fobject :int :c)))
  58     (declare (dynamic-extent ptr))
  59     (setf (ff:fslot-value-typed :int :c ptr) 0)
  60     (ff:free-fobject ptr))
  61   #+lispworks
  62   (let ((ptr (fli:allocate-foreign-object :type :int)))
  63     (declare (dynamic-extent ptr))
  64     (setf (fli:dereference ptr) 0)
  65     (fli:free-foreign-object ptr))
  66   #+cmu
  67   (let ((ptr (alien:make-alien (alien:signed 32))))
  68     (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
  69              (dynamic-extent ptr))
  70     (setf (alien:deref ptr) 0)
  71     (alien:free-alien ptr))
  72   #+sbcl
  73   (let ((ptr (sb-alien:make-alien (sb-alien:signed 32))))
  74     (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
  75      (dynamic-extent ptr))
  76     (setf (sb-alien:deref ptr) 0)
  77     (sb-alien:free-alien ptr))
  78   )
  79
  80 (defun stat-vector ()
  81   #+allegro
  82   (let ((ptr (ff:allocate-fobject '(:array :int 10) :c)))
  83     (declare (dynamic-extent ptr))
  84     (setf (ff:fslot-value-typed '(:array :int 10) :c ptr 5) 0)
  85     (ff:free-fobject ptr))
  86   #+lispworks
  87   (let ((ptr (fli:allocate-foreign-object :type '(:c-array :int 10))))
  88     (declare (dynamic-extent ptr))
  89     (setf (fli:dereference ptr 5) 0)
  90     (fli:free-foreign-object ptr))
  91   #+cmu
  92   (let ((ptr (alien:make-alien (alien:array (alien:signed 32) 10))))
  93     (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
  94              (dynamic-extent ptr))
  95     (setf (alien:deref ptr 5) 0)
  96     (alien:free-alien ptr))
  97   #+sbcl
  98   (let ((ptr (sb-alien:make-alien (sb-alien:array (sb-alien:signed 32) 10))))
  99     (declare ;;(type (sb-alien (* (sb-alien:unsigned 32))) ptr)
 100              (dynamic-extent ptr))
 101     (setf (sb-alien:deref ptr 5) 0)
 102     (sb-alien:free-alien ptr))
 103   )
 104
 105
 106 (defun stk-vs-stat ()
 107   (format t "~&Stack allocation, Integer")
 108   (time (dotimes (i 1000)
 109           (dotimes (j 1000)
 110             (stk-int))))
 111   (format t "~&Static allocation, Integer")
 112   (time (dotimes (i 1000)
 113           (dotimes (j 1000)
 114             (stat-int))))
 115   (format t "~&Stack allocation, Vector")
 116   (time (dotimes (i 1000)
 117           (dotimes (j 1000)
 118             (stk-int))))
 119   (format t "~&Static allocation, Vector")
 120   (time (dotimes (i 1000)
 121           (dotimes (j 1000)
 122             (stat-int))))
 123 )
 124
 125
 126 (stk-vs-stat)
 127
 128
 129