mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-01 01:40:21 +02:00
Code Activity

More efficient assembler instructions

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-12-01 17:04:36 +01:00
parent 73065c7131
commit dbd9265cc0
1 changed files with 60 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

95
module/system/vm/assembler.scm
View file

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