[Guile-commits] 40/41: More efficient assembler instructions

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit dbd9265cc0994c30429070136708b64a75ddf20a
Author: Andy Wingo <address@hidden>
Date:   Tue Dec 1 17:04:36 2015 +0100

    More efficient assembler instructions
    
    * module/system/vm/assembler.scm (pack-u8-u24, pack-u8-s24):
      (pack-u1-u7-u24, pack-u8-u12-u12, pack-u8-u8-u16): Tweak to expose
      more possibilities for untagging u64 values.
---
 module/system/vm/assembler.scm |   95 +++++++++++++++++++++++++---------------
 1 files changed, 60 insertions(+), 35 deletions(-)

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index f94d0f0..e5f464b 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -229,57 +229,82 @@
 ;;; These helpers create one 32-bit unit from multiple components.
 
 (define-inline (pack-u8-u24 x y)
-  (unless (<= 0 x 255)
-    (error "out of range" x))
-  (logior x (ash y 8)))
+  (let ((x* (logand x #xff))
+        (y* (logand y #xffffff)))
+    (unless (= x x*)
+      (error "out of range" x))
+    (unless (= y y*)
+      (error "out of range" y))
+    (logior x* (ash y* 8))))
 
 (define-inline (pack-u8-s24 x y)
-  (unless (<= 0 x 255)
-    (error "out of range" x))
-  (logior x (ash (cond
-                  ((< 0 (- y) #x800000)
-                   (+ y #x1000000))
-                  ((<= 0 y #xffffff)
-                   y)
-                  (else (error "out of range" y)))
-                 8)))
+  (let ((x* (logand x #xff))
+        (y* (logand y #xffffff)))
+    (unless (= x x*)
+      (error "out of range" x))
+    (unless (if (< y* #x800000)
+                (= y y*)
+                (= (+ y #x1000000) y*))
+      (error "out of range" y))
+    (logior x* (ash y* 8))))
 
 (define-inline (pack-u1-u7-u24 x y z)
-  (unless (<= 0 x 1)
-    (error "out of range" x))
-  (unless (<= 0 y 127)
-    (error "out of range" y))
-  (logior x (ash y 1) (ash z 8)))
+  (let ((x* (logand x #x1))
+        (y* (logand y #x7f))
+        (z* (logand z #xffffff)))
+    (unless (= x x*)
+      (error "out of range" x))
+    (unless (= y y*)
+      (error "out of range" y))
+    (unless (= z z*)
+      (error "out of range" z))
+    (logior x* (ash y* 1) (ash z* 8))))
 
 (define-inline (pack-u8-u12-u12 x y z)
-  (unless (<= 0 x 255)
-    (error "out of range" x))
-  (unless (<= 0 y 4095)
-    (error "out of range" y))
-  (logior x (ash y 8) (ash z 20)))
+  (let ((x* (logand x #xff))
+        (y* (logand y #xfff))
+        (z* (logand z #xfff)))
+    (unless (= x x*)
+      (error "out of range" x))
+    (unless (= y y*)
+      (error "out of range" y))
+    (unless (= z z*)
+      (error "out of range" z))
+    (logior x* (ash y* 8) (ash z* 20))))
 
 (define-inline (pack-u8-u8-u16 x y z)
-  (unless (<= 0 x 255)
-    (error "out of range" x))
-  (unless (<= 0 y 255)
-    (error "out of range" y))
-  (logior x (ash y 8) (ash z 16)))
+  (let ((x* (logand x #xff))
+        (y* (logand y #xff))
+        (z* (logand z #xffff)))
+    (unless (= x x*)
+      (error "out of range" x))
+    (unless (= y y*)
+      (error "out of range" y))
+    (unless (= z z*)
+      (error "out of range" z))
+    (logior x* (ash y* 8) (ash z* 16))))
 
 (define-inline (pack-u8-u8-u8-u8 x y z w)
-  (unless (<= 0 x 255)
-    (error "out of range" x))
-  (unless (<= 0 y 255)
-    (error "out of range" y))
-  (unless (<= 0 z 255)
-    (error "out of range" z))
-  (logior x (ash y 8) (ash z 16) (ash w 24)))
+  (let ((x* (logand x #xff))
+        (y* (logand y #xff))
+        (z* (logand z #xff))
+        (w* (logand w #xff)))
+    (unless (= x x*)
+      (error "out of range" x))
+    (unless (= y y*)
+      (error "out of range" y))
+    (unless (= z z*)
+      (error "out of range" z))
+    (unless (= w w*)
+      (error "out of range" w))
+    (logior x* (ash y* 8) (ash z* 16) (ash w* 24))))
 
 (eval-when (expand)
   (define-syntax pack-flags
     (syntax-rules ()
       ;; Add clauses as needed.
       ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
-                                  (if f2 (ash 2 0) 0))))))
+                                  (if f2 (ash 1 1) 0))))))
 
 ;;; Helpers to read and write 32-bit units in a buffer.