optimize some bytevector functions

refactor some sequence-related functions

Author: cosmos72

Makefile

@@ -66,7 +66,7 @@ containers.o: containers/containers.c containers/containers.h eval.h
 eval.o: eval.c eval.h
 	$(CC) -o $@ -c $< $(CFLAGS) -I"$(CHEZ_SCHEME_DIR)"
 
-posix.o: posix/posix.c posix/posix.h eval.h
+posix.o: posix/posix.c posix/posix.h posix/signal.h eval.h
 	$(CC) -o $@ -c $< $(CFLAGS) -I"$(CHEZ_SCHEME_DIR)"
 
 shell.o: shell/shell.c shell/shell.h containers/containers.h eval.h posix/posix.h

bootstrap/bootstrap.ss

@@ -130,10 +130,15 @@
       (syntax-case stx ()
         ((_ caller (proc args ...))
           (with-syntax (((targs ...) (generate-pretty-temporaries #'(args ...))))
-            #`(let ((tproc proc) (targs args) ...)
-                (if (tproc targs ...)
-                  (void)
-                  (raise-assert* caller #,form targs ...)))))
+            (if (symbol? (syntax->datum #'proc))
+              #`(let ((targs args) ...) ;; proc is a symbol, no need to save its value into a local variable
+                  (if (proc targs ...)
+                    (void)
+                    (raise-assert* caller #,form targs ...)))
+              #`(let ((tproc proc) (targs args) ...)
+                  (if (tproc targs ...)
+                    (void)
+                    (raise-assert* caller #,form targs ...))))))
         ((_ caller expr)
           #`(let ((texpr expr))
               (if texpr

containers/bytespan.ss

@@ -29,7 +29,7 @@
     (only (chezscheme)         bytevector-truncate! fx1+ fx1- record-writer void)
     (only (schemesh bootstrap) assert* assert-not*)
     (only (schemesh containers list) list-iterate)
-    (schemesh containers misc))
+    (schemesh containers bytevector))
 
 (define-record-type
   (%bytespan %make-bytespan bytespan?)
@@ -112,7 +112,8 @@
                           (bytespan-end sp) u8))
 
 (define (bytespan-fill-range! sp start end u8)
-  (assert* 'bytespan-fill-range! (fx<=? 0 start end (bytespan-length sp)))
+  (assert* 'bytespan-fill-range! (fx<=? 0 start end))
+  (assert* 'bytespan-fill-range! (fx<=? end (bytespan-length sp)))
   (let ((offset (bytespan-beg sp)))
     (bytevector-fill-range! (bytespan-vec sp) (fx+ start offset) (fx+ end offset) u8)))
 
@@ -124,8 +125,11 @@
     dst))
 
 (define (bytespan-copy! src src-start dst dst-start n)
-  (assert* 'bytespan-copy! (fx<=? 0 src-start (fx+ src-start n) (bytespan-length src)))
-  (assert* 'bytespan-copy! (fx<=? 0 dst-start (fx+ dst-start n) (bytespan-length dst)))
+  ;; assert* allocates if too many arguments
+  (assert* 'bytespan-copy! (fx<=? 0 src-start (fx+ src-start n)))
+  (assert* 'bytespan-copy! (fx<=? 0 dst-start (fx+ dst-start n)))
+  (assert* 'bytespan-copy! (fx<=? (fx+ src-start n) (bytespan-length src)))
+  (assert* 'bytespan-copy! (fx<=? (fx+ dst-start n) (bytespan-length dst)))
   (bytevector-copy! (bytespan-vec src) (fx+ src-start (bytespan-beg src))
                 (bytespan-vec dst) (fx+ dst-start (bytespan-beg dst)) n))
 
@@ -285,8 +289,10 @@
 (define bytespan-insert-right/bspan!
   (case-lambda
     ((sp-dst sp-src src-start src-end)
+      ;; assert* allocates if too many arguments
       (assert-not* 'bytespan-insert-right/bspan! (eq? sp-dst sp-src))
-      (assert*     'bytespan-insert-right/bspan! (fx<=? 0 src-start src-end (bytespan-length sp-src)))
+      (assert*     'bytespan-insert-right/bspan! (fx<=? 0 src-start src-end))
+      (assert*     'bytespan-insert-right/bspan! (fx<=? src-end (bytespan-length sp-src)))
       (when (fx<? src-start src-end)
         ;; check for (not (eq? src dst)) only if dst is non-empty,
         ;; because reusing the empty bytevector is a common optimization of Scheme compilers
@@ -329,20 +335,16 @@
 (define in-bytespan
   (case-lambda
     ((sp start end step)
-      (assert* 'in-bytespan (fx<=? 0 start end (bytespan-length sp)))
+      (assert* 'in-bytespan (fx<=? 0 start end))
+      (assert* 'in-bytespan (fx<=? end (bytespan-length sp)))
       (assert* 'in-bytespan (fx>=? step 0))
-      (lambda ()
-        (if (fx<? start end)
-          (let ((elem (bytespan-ref/u8 sp start)))
-            (set! start (fx+ start step))
-            (values elem #t))
-          (values 0 #f))))
+      (let ((offset (bytespan-beg sp)))
+        (in-bytevector (bytespan-vec sp) (fx+ start offset) (fx+ end offset) step)))
     ((sp start end)
       (in-bytespan sp start end 1))
     ((sp)
       (in-bytespan sp 0 (bytespan-length sp) 1))))
 
-
 ;; (bytespan-iterate l proc) iterates on all elements of given bytespan sp,
 ;; and calls (proc index elem) on each element. stops iterating if (proc ...) returns #f
 ;;

containers/bytevector.ss

@@ -9,40 +9,78 @@
 ;; this file should be included only by file containers/misc.ss
 
 
+(library (schemesh containers bytevector (0 8 1))
+  (export
+    in-bytevector list->bytevector subbytevector
+    bytevector-fill-range! bytevector-index bytevector-compare
+    bytevector<=? bytevector<? bytevector>=? bytevector>? bytevector-iterate)
+  (import
+    (rnrs)
+    (rnrs mutable-pairs)
+    (only (chezscheme)         bytevector foreign-procedure fx1+ logbit? procedure-arity-mask)
+    (only (schemesh bootstrap) assert*))
+
+
+;; each element in list l must be a fixnum in the range [-128, 255]
 (define (list->bytevector l)
   (apply bytevector l))
 
 
 ;; return a copy of bytevector bvec containing only elements
 ;; from start (inclusive) to end (exclusive)
 (define (subbytevector bvec start end)
-  (assert* 'subbytevector (fx<=? 0 start end (bytevector-length bvec)))
+  (assert* 'subbytevector (fx<=? 0 start end))
+  (assert* 'subbytevector (fx<=? end (bytevector-length bvec)))
   (let* ((n (fx- end start))
          (dst (make-bytevector n)))
     (bytevector-copy! bvec start dst 0 n)
     dst))
 
-(define (bytevector-fill-range! bvec start end val)
-  (assert* 'bytevector-fill-range! (fx<=? 0 start end (bytevector-length bvec)))
-  (do ((i start (fx1+ i)))
-      ((fx>=? i end))
-    (bytevector-u8-set! bvec i val)))
-
-
-;; search bytevector range [start, end) and return index of first byte equal to b.
+(define bytevector-fill-range!
+  (let ((c-bytevector-fill-range (foreign-procedure "c_bytevector_fill_range" (ptr int int int) void)))
+    (lambda (bvec start end val)
+      ;; assert* allocates if too many arguments
+      (assert* 'bytevector-fill-range! (fx<=? 0 start end))
+      (assert* 'bytevector-fill-range! (fx<=? end (bytevector-length bvec)))
+      (assert* 'bytevector-fill-range! (fx<=? -128 val 255))
+      (let ((val (fxand val 255))
+            (n   (fx- end start)))
+        (if (fx<? n 3)
+          (unless (fxzero? n)
+            (bytevector-u8-set! bvec start val)
+            (when (fx>? n 1)
+              (bytevector-u8-set! bvec (fx1+ start) val)))
+          (c-bytevector-fill-range bvec start end val))))))
+
+
+;; search bytevector range [start, end) and return index of first byte equal to u8 or that satisfies pred.
 ;; returned numerical index will be in the range [start, end).
 ;; return #f if no such byte is found in range.
-(define bytevector-index/u8
-  (case-lambda
-    ((bvec start end b)
-      (assert* 'bytevector-index/u8 (bytevector? bvec))
-      (assert* 'bytevector-index/u8 (fx<=? 0 start end (bytevector-length bvec)))
-      (assert* 'bytevector-index/u8 (fx<=? 0 b 255))
-      (do ((i start (fx1+ i)))
-          ((or (fx>=? i end) (fx=? b (bytevector-u8-ref bvec i)))
-            (if (fx>=? i end) #f i))))
-    ((bvec b)
-      (bytevector-index/u8 bvec 0 (bytevector-length bvec) b))))
+(define bytevector-index
+  (let ((c-bytevector-index-u8 (foreign-procedure "c_bytevector_index_u8" (ptr int int int) ptr)))
+    (case-lambda
+      ((bvec start end byte-or-pred)
+        ;; assert* allocates if too many arguments
+        (assert* 'bytevector-index (bytevector? bvec))
+        (assert* 'bytevector-index (fx<=? 0 start end))
+        (assert* 'bytevector-index (fx<=? end (bytevector-length bvec)))
+        (if (fixnum? byte-or-pred)
+          (begin
+            (assert* 'bytevector-index (fx<=? -128 byte-or-pred 255))
+            (let ((u8 (fxand byte-or-pred 255)))
+              (if (fx<? (fx- end start) 4)
+                (do ((i start (fx1+ i)))
+                    ((or (fx>=? i end) (fx=? u8 (bytevector-u8-ref bvec i)))
+                      (if (fx<? i end) i #f)))
+                (c-bytevector-index-u8 bvec start end u8))))
+          (begin
+            (assert* 'bytevector-index (logbit? 1 (procedure-arity-mask byte-or-pred)))
+            (let ((pred byte-or-pred))
+              (do ((i start (fx1+ i)))
+                ((or (fx>=? i end) (pred (bytevector-u8-ref bvec i)))
+                  (if (fx<? i end) i #f)))))))
+      ((bvec byte-or-pred)
+        (bytevector-index bvec 0 (bytevector-length bvec) byte-or-pred)))))
 
 
 
@@ -56,12 +94,14 @@
     ((sp start end step)
       (assert* 'in-bytevector (fx<=? 0 start end (bytevector-length sp)))
       (assert* 'in-bytevector (fx>=? step 0))
-      (lambda ()
-        (if (fx<? start end)
-          (let ((elem (bytevector-u8-ref sp start)))
-            (set! start (fx+ start step))
-            (values elem #t)))
-          (values 0 #f)))
+      (let ((%in-bytevector ; name shown when displaying the closure
+              (lambda ()
+                (if (fx<? start end)
+                  (let ((elem (bytevector-u8-ref sp start)))
+                    (set! start (fx+ start step))
+                    (values elem #t)))
+                  (values 0 #f))))
+        %in-bytevector))
     ((sp start end)
       (in-bytevector sp start end 1))
     ((sp)
@@ -80,6 +120,7 @@
       ((or (fx>=? i n) (not (proc i (bytevector-u8-ref bvec i))))
        (fx>=? i n))))
 
+
 ;; compare the two bytevectors bvec1 and bvec2.
 ;; return -1 if bvec1 is lexicographically lesser than bvec2,
 ;; return 0 if they are equal,
@@ -93,6 +134,7 @@
       (or (eq? bvec1 bvec2)
           (c-bytevector-compare bvec1 bvec2)))))
 
+
 (define (bytevector<=? bvec1 bvec2)
   (fx<=? (bytevector-compare bvec1 bvec2) 0))
 
@@ -104,3 +146,5 @@
 
 (define (bytevector>? bvec1 bvec2)
   (fx>? (bytevector-compare bvec1 bvec2) 0))
+
+) ; close library

containers/chargbuffer.ss

@@ -221,12 +221,14 @@
     ((gb start end step)
       (assert* 'in-chargbuffer (fx<=? 0 start end (chargbuffer-length gb)))
       (assert* 'in-chargbuffer (fx>=? step 0))
-      (lambda ()
-        (if (fx<? start end)
-          (let ((elem (chargbuffer-ref gb start)))
-            (set! start (fx+ start step))
-            (values elem #t))
-          (values #\nul #f))))
+      (let ((%in-chargbuffer ; name shown when displaying the closure
+              (lambda ()
+                (if (fx<? start end)
+                  (let ((elem (chargbuffer-ref gb start)))
+                    (set! start (fx+ start step))
+                    (values elem #t))
+                  (values #\nul #f)))))
+        %in-chargbuffer))
     ((gb start end)
       (in-chargbuffer gb start end 1))
     ((gb)

containers/charline.ss

@@ -264,12 +264,14 @@
     ((line start end step)
       (assert* 'in-charline (fx<=? 0 start end (charline-length line)))
       (assert* 'in-charline (fx>=? step 0))
-      (lambda ()
-        (if (fx<? start end)
-          (let ((elem (charline-ref line start)))
-            (set! start (fx+ start step))
-            (values elem #t))
-          (values #\nul #f))))
+      (let ((%in-charline ; name shown when displaying the closure
+              (lambda ()
+                (if (fx<? start end)
+                  (let ((elem (charline-ref line start)))
+                    (set! start (fx+ start step))
+                    (values elem #t))
+                  (values #\nul #f)))))
+        %in-charline))
     ((line start end)
       (in-charline line start end 1))
     ((line)

containers/charlines.ss

@@ -366,12 +366,14 @@
     ((lines start end step)
       (assert* 'in-charlines (fx<=? 0 start end (charlines-length lines)))
       (assert* 'in-charlines (fx>=? step 0))
-      (lambda ()
-        (if (fx<? start end)
-          (let ((elem (charlines-ref lines start)))
-            (set! start (fx+ start step))
-            (values elem #t))
-          (values #f #f))))
+      (let ((%in-charlines ; name shown when displaying the closure
+              (lambda ()
+                (if (fx<? start end)
+                  (let ((elem (charlines-ref lines start)))
+                    (set! start (fx+ start step))
+                    (values elem #t))
+                  (values #f #f)))))
+        %in-charlines))
     ((lines start end)
       (in-charlines lines start end 1))
     ((lines)

containers/charspan.ss

@@ -406,12 +406,14 @@
     ((sp start end step)
       (assert* 'in-charspan (fx<=? 0 start end (charspan-length sp)))
       (assert* 'in-charspan (fx>=? step 0))
-      (lambda ()
-        (if (fx<? start end)
-          (let ((elem (charspan-ref sp start)))
-            (set! start (fx+ start step))
-            (values elem #t))
-          (values #\nul #f))))
+      (let ((%in-charspan ; name shown when displaying the closure
+              (lambda ()
+                (if (fx<? start end)
+                  (let ((elem (charspan-ref sp start)))
+                    (set! start (fx+ start step))
+                    (values elem #t))
+                  (values #\nul #f)))))
+        %in-charspan))
     ((sp start end)
       (in-charspan sp start end 1))
     ((sp)

containers/containers.c

@@ -51,6 +51,29 @@ static signed char c_bytevector_compare(ptr left, ptr right) {
   }
 }
 
+/** fill with value a bytevector range  */
+static void c_bytevector_fill_range(ptr bvec, iptr start, iptr end, int value) {
+  if (Sbytevectorp(bvec) && 0 <= start && start < end && end <= Sbytevector_length(bvec)) {
+    memset(Sbytevector_data(bvec) + start, value & 0xFF, (size_t)end - (size_t)start);
+  }
+}
+
+/**
+ * find first byte equal to value in bytevector range,
+ * and return its position in the range [start, end)
+ * return #f if no such byte was found.
+ */
+static ptr c_bytevector_index_u8(ptr bvec, iptr start, iptr end, int value) {
+  if (Sbytevectorp(bvec) && 0 <= start && start < end && end <= Sbytevector_length(bvec)) {
+    const octet* data  = Sbytevector_data(bvec) + start;
+    const octet* match = (const octet*)memchr(data, value & 0xFF, (size_t)end - (size_t)start);
+    if (match) {
+      return Sfixnum((size_t)(match - data));
+    }
+  }
+  return Sfalse;
+}
+
 /**
  * INTENTIONALLY fills string with Unicode codepoints in the surrogate range 0xDC80..0xDCFF,
  * which cannot be created with (integer->char).
@@ -366,6 +389,7 @@ static size_t c_bytes_utf8b_to_string_length(const octet* bytes, size_t len) {
   return ret;
 }
 
+#if 0
 /**
  * convert the range [start, end) of UTF-8b bytevector to UTF-32 string.
  * and return ONLY the length of converted string i.e. the number of Unicode codepoints.
@@ -390,6 +414,7 @@ static iptr c_bytevector_utf8b_to_string_length(ptr bvec, iptr start, iptr end)
   }
   return 0;
 }
+#endif /* 0 */
 
 static sizepair c_sizepair(const size_t byte_n, const size_t char_n) {
   sizepair ret;
@@ -511,12 +536,14 @@ ptr schemesh_Sbytevector(const char chars[], const size_t len) {
 
 void schemesh_register_c_functions_containers(void) {
   Sregister_symbol("c_bytevector_compare", &c_bytevector_compare);
+  Sregister_symbol("c_bytevector_fill_range", &c_bytevector_fill_range);
+  Sregister_symbol("c_bytevector_index_u8", &c_bytevector_index_u8);
   Sregister_symbol("c_string_fill_utf8b_surrogate_chars", &c_string_fill_utf8b_surrogate_chars);
   Sregister_symbol("c_string_to_utf8b_length", &c_string_to_utf8b_length);
   Sregister_symbol("c_string_to_utf8b_append", &c_string_to_utf8b_append);
 #if 0
   Sregister_symbol("c_string_to_utf8b", &c_string_to_utf8b);
-#endif /* 0 */
   Sregister_symbol("c_bytevector_utf8b_to_string_length", &c_bytevector_utf8b_to_string_length);
+#endif /* 0 */
   Sregister_symbol("c_bytevector_utf8b_to_string_append", &c_bytevector_utf8b_to_string_append);
 }