Benchmark for various ways of representing C structs in CHICKEN Scheme

benchmark-float.scm

#|

Benchmark for various ways of representing C structs in CHICKEN
Scheme. Compile with different flags to switch the representation.

Allocate memory in non-managed memory:

  csc -D use-alloc -O3 -profile ./benchmark-float.scm
  ./benchmark-float 2> profile-alloc.txt
  chicken-profile -sort-by-name >> profile-alloc.txt

Create blobs in managed memory:

  csc -D use-blobs -O3 -profile ./benchmark-float.scm
  ./benchmark-float 2> profile-blobs.txt
  chicken-profile -sort-by-name >> profile-blobs.txt

Create blobs in managed memory, with locatives:

  csc -D use-blob-locatives -O3 -profile ./benchmark-float.scm
  ./benchmark-float 2> profile-blob-locatives.txt
  chicken-profile -sort-by-name >> profile-blob-locatives.txt

Create SRFI-4 numeric vectors:

  csc -D use-srfi-4 -O3 -profile ./benchmark-float.scm
  ./benchmark-float 2> profile-srfi-4.txt
  chicken-profile -sort-by-name >> profile-srfi-4.txt

|#


(import foreign)
(use lolevel srfi-4 miscmacros)


#>
#include "math.h"

typedef struct My_Point {
  float x, y;
} My_Point;

float my_point_mag(My_Point* pt) {
  return sqrt(pt->x * pt->x + pt->y * pt->y);
}
<#


(define-record-type point
  (wrap-point data)
  point?
  (data point-data point-data-set!))


(define (alloc-point)
  (cond-expand
    (use-alloc
     (set-finalizer!
      (wrap-point (allocate (foreign-type-size "My_Point")))
      free-point!))
    (use-blobs
     (wrap-point (make-blob (foreign-type-size "My_Point"))))
    (use-blob-locatives
     (wrap-point (make-locative (make-blob (foreign-type-size "My_Point")))))
    (use-srfi-4
     (wrap-point (make-f32vector 2)))))

(cond-expand
  (use-alloc
   (define (free-point! pt)
     (free (point-data pt))
     (point-data-set! pt #f)))
  (else))


(cond-expand
  ((or use-alloc use-blob-locatives)
   (define-foreign-type My_Point*
     (c-pointer "My_Point")
     point-data))
  (use-blobs
   (define-foreign-type My_Point*
     blob
     point-data))
  (use-srfi-4
   (define-foreign-type My_Point*
     f32vector
     point-data)))


(cond-expand
  ((or use-alloc use-blob-locatives)
   (define point-x (foreign-lambda* float ((My_Point* obj)) "C_return(obj->x);"))
   (define point-x-set! (foreign-lambda* void ((My_Point* obj) (float value)) "obj->x = value;"))
   (define point-y (foreign-lambda* float ((My_Point* obj)) "C_return( obj->y );"))
   (define point-y-set! (foreign-lambda* void ((My_Point* obj) (float value)) "obj->y = value;")))

  (use-blobs
   (define point-x (foreign-lambda* float ((My_Point* obj)) "C_return( ((My_Point*)obj)->x );"))
   (define point-x-set! (foreign-lambda* void ((My_Point* obj) (float value)) "((My_Point*)obj)->x = value;"))
   (define point-y (foreign-lambda* float ((My_Point* obj)) "C_return( ((My_Point*)obj)->y );"))
   (define point-y-set! (foreign-lambda* void ((My_Point* obj) (float value)) "((My_Point*)obj)->y = value;")))

  (use-srfi-4
   (define (point-x pt) (f32vector-ref (point-data pt) 0))
   (define (point-x-set! pt value) (f32vector-set! (point-data pt) 0 value))
   (define (point-y pt) (f32vector-ref (point-data pt) 1))
   (define (point-y-set! pt value) (f32vector-set! (point-data pt) 1 value))))


(cond-expand
  ((or use-alloc use-blob-locatives)
   (define my_point_mag
     (foreign-lambda float my_point_mag My_Point*)))
  ((or use-blobs use-srfi-4)
   (define my_point_mag
     (foreign-lambda* float ((My_Point* p))
       "C_return( my_point_mag( (My_Point*)p ) );"))))


(define (bench)
  (dotimes (_ (expt 10 6))
    (let ((pt1 (alloc-point))
          (pt2 (alloc-point)))
      (point-x-set! pt1 -1.5)
      (point-y-set! pt1 2)
      (point-x-set! pt2 (* 2 (point-x pt1)))
      (point-y-set! pt2 (* 2 (point-y pt1)))
      (assert (< 4.99 (my_point_mag pt2) 5.01))))
  (gc #t))

(time (bench))