mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 08:20:20 +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.
(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.