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-2005 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; *************************************************************************
  15
  16 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  17 (in-package :cl-user)
  18
  19
  20 (defun stk-int ()
  21   #+allegro
  22   (ff:with-stack-fobject (ptr :int)
  23     (setf (ff:fslot-value ptr) 0))
  24   #+lispworks
  25   (fli:with-dynamic-foreign-objects ((ptr :int))
  26     (setf (fli:dereference ptr) 0))
  27   #+cmu
  28   (alien:with-alien ((ptr alien:signed))
  29     (let ((p (alien:addr ptr)))
  30       (setf (alien:deref p) 0)))
  31   #+sbcl
  32   (sb-alien:with-alien ((ptr sb-alien:signed))
  33     (let ((p (sb-alien:addr ptr)))
  34       (setf (sb-alien:deref p) 0)))
  35   )
  36
  37 (defun stk-vector ()
  38   #+allegro
  39   (ff:with-stack-fobject (ptr '(:array :int 10) )
  40     (setf (ff:fslot-value ptr 5) 0))
  41   #+lispworks
  42   (fli:with-dynamic-foreign-objects ((ptr (:c-array :int 10)))
  43     (setf (fli:dereference ptr 5) 0))
  44   #+cmu
  45   (alien:with-alien ((ptr (alien:array alien:signed 10)))
  46     (setf (alien:deref ptr 5) 0))
  47   #+sbcl
  48   (sb-alien:with-alien ((ptr (sb-alien:array sb-alien:signed 10)))
  49     (setf (sb-alien:deref ptr 5) 0))
  50   )
  51
  52 (defun stat-int ()
  53   #+allegro
  54   (let ((ptr (ff:allocate-fobject :int :c)))
  55     (declare (dynamic-extent ptr))
  56     (setf (ff:fslot-value-typed :int :c ptr) 0)
  57     (ff:free-fobject ptr))
  58   #+lispworks
  59   (let ((ptr (fli:allocate-foreign-object :type :int)))
  60     (declare (dynamic-extent ptr))
  61     (setf (fli:dereference ptr) 0)
  62     (fli:free-foreign-object ptr))
  63   #+cmu
  64   (let ((ptr (alien:make-alien (alien:signed 32))))
  65     (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
  66              (dynamic-extent ptr))
  67     (setf (alien:deref ptr) 0)
  68     (alien:free-alien ptr))
  69   #+sbcl
  70   (let ((ptr (sb-alien:make-alien (sb-alien:signed 32))))
  71     (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
  72      (dynamic-extent ptr))
  73     (setf (sb-alien:deref ptr) 0)
  74     (sb-alien:free-alien ptr))
  75   )
  76
  77 (defun stat-vector ()
  78   #+allegro
  79   (let ((ptr (ff:allocate-fobject '(:array :int 10) :c)))
  80     (declare (dynamic-extent ptr))
  81     (setf (ff:fslot-value-typed '(:array :int 10) :c ptr 5) 0)
  82     (ff:free-fobject ptr))
  83   #+lispworks
  84   (let ((ptr (fli:allocate-foreign-object :type '(:c-array :int 10))))
  85     (declare (dynamic-extent ptr))
  86     (setf (fli:dereference ptr 5) 0)
  87     (fli:free-foreign-object ptr))
  88   #+cmu
  89   (let ((ptr (alien:make-alien (alien:array (alien:signed 32) 10))))
  90     (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
  91              (dynamic-extent ptr))
  92     (setf (alien:deref ptr 5) 0)
  93     (alien:free-alien ptr))
  94   #+sbcl
  95   (let ((ptr (sb-alien:make-alien (sb-alien:array (sb-alien:signed 32) 10))))
  96     (declare ;;(type (sb-alien (* (sb-alien:unsigned 32))) ptr)
  97              (dynamic-extent ptr))
  98     (setf (sb-alien:deref ptr 5) 0)
  99     (sb-alien:free-alien ptr))
 100   )
 101
 102
 103 (defun stk-vs-stat ()
 104   (format t "~&Stack allocation, Integer")
 105   (time (dotimes (i 1000)
 106           (dotimes (j 1000)
 107             (stk-int))))
 108   (format t "~&Static allocation, Integer")
 109   (time (dotimes (i 1000)
 110           (dotimes (j 1000)
 111             (stat-int))))
 112   (format t "~&Stack allocation, Vector")
 113   (time (dotimes (i 1000)
 114           (dotimes (j 1000)
 115             (stk-int))))
 116   (format t "~&Static allocation, Vector")
 117   (time (dotimes (i 1000)
 118           (dotimes (j 1000)
 119             (stat-int))))
 120 )
 121
 122
 123 (stk-vs-stat)
 124
 125
 126