[Chicken-hackers] [PATCH] use inline safe block-accessors

[Felix]

The attached patch provides a more efficient implementation of low-level
block accessors ("##sys#block-ref"/"##sys#block-set!", usually needed 
for record-structures, and "matchable". These primitives are safe (in
contrast to "##sys#slot"/"##sys#setslot"), in that they handle invalid
slot-indices. The new C-level equivalents "C_i_fast_block_ref" and
"C_i_fast_block_set" are defined in chicken.h as inline functions.


cheers,
felix

>From a3faffa3f143b323f0a573c975ee976d6bb0177a Mon Sep 17 00:00:00 2001
From: Felix Winkelmann <address@hidden>
Date: Tue, 9 Oct 2012 03:39:43 -0400
Subject: [PATCH] Inline low-level record structure accessors

"##sys#block-ref" and "##sys#block-set!" are re-written to simpler
calls to C inline functions ("C_fast_block_ref" and
"C_fast_block_set"), defined in "chicken.h". These functions are safe
in the sense that they will not crash if the slot index is invalid.
---
 c-platform.scm |   10 +++++-----
 chicken.h      |   34 +++++++++++++++++++++++++++++++++-
 library.scm    |   10 ++--------
 runtime.c      |    2 +-
 4 files changed, 41 insertions(+), 15 deletions(-)

diff --git a/c-platform.scm b/c-platform.scm
index c64db6c..c63e7fd 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -200,7 +200,7 @@
     f32vector->blob/shared f64vector->blob/shared
     s32vector->blob/shared read-string read-string! o
     address->pointer pointer->address
-    ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot 
##sys#block-ref
+    ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot
     ##sys#byte ##sys#setbyte ##sys#get-keyword get-keyword
     u8vector-length s8vector-length u16vector-length s16vector-length 
u32vector-length s32vector-length
     f32vector-length f64vector-length ##sys#apply-values ##sys#setter setter
@@ -635,7 +635,8 @@
 (rewrite 'char>=? 2 2 "C_i_char_greater_or_equal_p" #t)
 (rewrite 'char<=? 2 2 "C_i_char_less_or_equal_p" #t)
 (rewrite '##sys#slot 2 2 "C_slot" #t)          ; consider as safe, the 
primitive is unsafe anyway.
-(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t) ;XXX must be safe for 
pattern matcher (anymore?)
+(rewrite '##sys#block-ref 2 2 "C_i_fast_block_ref" #t)
+(rewrite '##sys#block-set! 2 3 "C_i_fast_block_set" #t)
 (rewrite '##sys#size 2 1 "C_block_size" #t)
 (rewrite 'fxnot 2 1 "C_fixnum_not" #t)
 (rewrite 'fx* 2 2 "C_fixnum_times" #t)
@@ -667,7 +668,6 @@
 (rewrite 'list-tail 2 2 "C_i_list_tail" #t)
 (rewrite '##sys#structure? 2 2 "C_i_structurep" #t)
 (rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t)
-(rewrite 'block-ref 2 2 "C_slot" #f)   ; ok to be unsafe, lolevel is anyway
 (rewrite 'number-of-slots 2 1 "C_block_size" #f)
 
 (rewrite 'assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq")
@@ -767,8 +767,8 @@
 (rewrite 'setter 11 1 '##sys#setter #t)
 (rewrite 'for-each 11 2 '##sys#for-each #t)
 (rewrite 'map 11 2 '##sys#map #t)
-(rewrite 'block-set! 11 3 '##sys#setslot #t)
-(rewrite '##sys#block-set! 11 3 '##sys#setslot #f)
+(rewrite 'block-ref 11 2 '##sys#block-ref #t)
+(rewrite 'block-set! 11 3 '##sys#block-set! #t)
 (rewrite 'make-record-instance 11 #f '##sys#make-structure #f)
 (rewrite 'substring 11 3 '##sys#substring #f)
 (rewrite 'string-append 11 2 '##sys#string-append #f)
diff --git a/chicken.h b/chicken.h
index 5ba5722..eb14a97 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1779,7 +1779,7 @@ C_fctexport C_word C_fcall C_u_i_evenp(C_word x) 
C_regparm;
 C_fctexport C_word C_fcall C_i_oddp(C_word x) C_regparm;
 C_fctexport C_word C_fcall C_u_i_oddp(C_word x) C_regparm;
 C_fctexport C_word C_fcall C_i_vector_ref(C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_i_block_ref(C_word x, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_block_ref(C_word x, C_word i) C_regparm; /* 
OBSOLETE */
 C_fctexport C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c) 
C_regparm;
 C_fctexport C_word C_fcall C_i_string_ref(C_word s, C_word i) C_regparm;
 C_fctexport C_word C_fcall C_i_vector_length(C_word v) C_regparm;
@@ -2728,6 +2728,38 @@ C_inline C_word C_a_i_record8(C_word **ptr, int n, 
C_word x1, C_word x2, C_word
 }
 
 
+C_inline C_word
+C_i_fast_block_ref(C_word x, C_word i)
+{
+  /* like C_i_block_ref, but assumes argument is non-immediate and index is 
fixnum;
+     returns undefined if length doesn't match. */
+  int j;
+
+  j = C_unfix(i);
+
+  if(j < 0 || j >= C_header_size(x)) return C_SCHEME_UNDEFINED;
+  else return C_block_item(x, j);
+}
+
+
+C_inline C_word
+C_i_fast_block_set(C_word x, C_word i, C_word y)
+{
+  /* like C_i_block_ref, but assumes argument is non-immediate and index is 
fixnum;
+     does nothing if length doesn't match. */
+  int j;
+
+  j = C_unfix(i);
+
+  if(j >= 0 && j < C_header_size(x)) {
+    if(C_immediatep(y)) C_set_block_item(x, j, y);
+    else C_mutate_slot(&C_block_item(x, j), y);
+  }
+
+  return y;
+}
+
+
 #ifdef C_PRIVATE_REPOSITORY
 # if defined(C_MACOSX) && defined(C_GUI)
 #  include <CoreFoundation/CoreFoundation.h>
diff --git a/library.scm b/library.scm
index 8ea65ca..3756215 100644
--- a/library.scm
+++ b/library.scm
@@ -224,18 +224,12 @@ EOF
 (define (##sys#halt msg) (##core#inline "C_halt" msg))
 (define (##sys#flo2fix n) (##core#inline "C_quickflonumtruncate" n))
 (define ##sys#become! (##core#primitive "C_become"))
-(define (##sys#block-ref x i) (##core#inline "C_i_block_ref" x i))
 (define ##sys#apply-values (##core#primitive "C_apply_values"))
 (define ##sys#copy-closure (##core#primitive "C_copy_closure"))
 (define ##sys#apply-argument-limit (##sys#fudge 34))
 
-(define (##sys#block-set! x i y)
-  (when (or (not (##core#inline "C_blockp" x)) 
-           (and (##core#inline "C_specialp" x) (fx= i 0))
-           (##core#inline "C_byteblockp" x) ) 
-    (##sys#signal-hook '#:type-error '##sys#block-set! "slot not accessible" 
x) )
-  (##sys#check-range i 0 (##sys#size x) '##sys#block-set!)
-  (##sys#setslot x i y) )
+(define (##sys#block-ref x i) (##core#inline "C_i_fast_block_ref" x i))
+(define (##sys#block-set! x i y) (##core#inline "C_i_fast_block_set" x i y))
 
 (define (current-seconds) 
   (##core#inline_allocate ("C_a_get_current_seconds" 4) #f))
diff --git a/runtime.c b/runtime.c
index 98f9706..ddca09c 100644
--- a/runtime.c
+++ b/runtime.c
@@ -4853,7 +4853,7 @@ C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word 
i)
 }
 
 
-C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)
+C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i) /* OBSOLETE */
 {
   int j;
 
-- 
1.7.2.1