From 9dea2abec2aed327358d6d6b37af59449f9e55c9 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@users.sourceforge.net>
Date: Sun, 25 Apr 2010 16:49:59 +0200
Subject: [PATCH] Inline expansions for %MEM-SET/REF when using the ECL backend.

---
 src/cffi-ecl.lisp |   70 ++++++++++++++++++++++++++++++++++++++++-------------
 1 files changed, 53 insertions(+), 17 deletions(-)

diff --git a/src/cffi-ecl.lisp b/src/cffi-ecl.lisp
index b3398d3..a729e5e 100644
--- a/src/cffi-ecl.lisp
+++ b/src/cffi-ecl.lisp
@@ -165,23 +165,6 @@ WITH-POINTER-TO-VECTOR-DATA."
   `(let ((,ptr-var (make-pointer (%vector-address ,vector))))
      ,@body))
 
-;;;# Dereferencing
-
-(defun %mem-ref (ptr type &optional (offset 0))
-  "Dereference an object of TYPE at OFFSET bytes from PTR."
-  (let* ((type (cffi-type->ecl-type type))
-         (type-size (ffi:size-of-foreign-type type)))
-    (si:foreign-data-ref-elt
-     (si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
-
-(defun %mem-set (value ptr type &optional (offset 0))
-  "Set an object of TYPE at OFFSET bytes from PTR."
-  (let* ((type (cffi-type->ecl-type type))
-         (type-size (ffi:size-of-foreign-type type)))
-    (si:foreign-data-set-elt
-     (si:foreign-data-recast ptr (+ offset type-size) :void)
-     offset type value)))
-
 ;;;# Type Operations
 
 (defconstant +translation-table+
@@ -222,6 +205,59 @@ WITH-POINTER-TO-VECTOR-DATA."
   (nth-value 1 (ffi:size-of-foreign-type
                 (cffi-type->ecl-type type-keyword))))
 
+;;;# Dereferencing
+
+(defun %mem-ref (ptr type &optional (offset 0))
+  "Dereference an object of TYPE at OFFSET bytes from PTR."
+  (let* ((type (cffi-type->ecl-type type))
+         (type-size (ffi:size-of-foreign-type type)))
+    (si:foreign-data-ref-elt
+     (si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
+
+(defun %mem-set (value ptr type &optional (offset 0))
+  "Set an object of TYPE at OFFSET bytes from PTR."
+  (let* ((type (cffi-type->ecl-type type))
+         (type-size (ffi:size-of-foreign-type type)))
+    (si:foreign-data-set-elt
+     (si:foreign-data-recast ptr (+ offset type-size) :void)
+     offset type value)))
+
+;;;# Inline versions that use C expressions instead of function calls.
+
+(defparameter +mem-ref-strings+
+  (loop for (cffi-type ecl-type c-string) in +translation-table+
+     for string = (format nil "*((~A *)(((char*)#0)+#1))" c-string)
+     collect (list cffi-type ecl-type string)))
+                   
+(defparameter +mem-set-strings+
+  (loop for (cffi-type ecl-type c-string) in +translation-table+
+     for string = (format nil "*((~A *)(((char*)#0)+#1))=#2" c-string)
+     collect (list cffi-type ecl-type string)))
+
+(define-compiler-macro %mem-ref (&whole whole ptr type &optional (offset 0))
+  (if (and (constantp type) (constantp offset))
+      (let ((record (assoc (eval type) +mem-ref-strings+)))
+        `(ffi:c-inline (,ptr ,offset)
+                       (:pointer-void :cl-index) ; argument types
+                       ,(second record) ; return type
+                       ,(third record) ; the precomputed expansion
+                       :one-liner t))
+      whole))
+
+(define-compiler-macro %mem-set (&whole whole value ptr type &optional (offset 0))
+  (if (and (constantp type) (constantp offset))
+      (let ((record (assoc (eval type) +mem-set-strings+))
+            (aux (gentemp)))
+        `(let ((,aux ,value))
+           (declare (:read-only ,aux))
+           (ffi:c-inline (,ptr ,offset ,aux) ; arguments with type translated
+                         (:pointer-void :cl-index ,(second record))
+                         :void ; does not return anything
+                         ,(third record) ; precomputed expansion
+                         :one-liner t)
+           ,aux))
+      whole))
+
 ;;;# Calling Foreign Functions
 
 (defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
-- 
1.6.6.1