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