[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/03: Add support for comparisons against integer immed
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/03: Add support for comparisons against integer immediates |
|
Date: |
Wed, 15 Nov 2017 08:19:21 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 294dbaad35e139427ecbfffa7b02f0a2ee037b9b
Author: Andy Wingo <address@hidden>
Date: Tue Nov 14 10:41:24 2017 +0100
Add support for comparisons against integer immediates
* libguile/vm-engine.c (s64-imm=?, u64-imm<?, imm-u64<?, s64-imm<?)
(imm-s64<?): New instructions.
* libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): Add new
X8_S12_Z12 word type used by the new S64/immediate instructions. A
Z12 is a 12-bit signed integer immediate.
* module/system/vm/assembler.scm: Export new instructions, and add
X8_S12_Z12 support. Also, add missing shufflers for X8_S12_C12.
* module/language/bytecode.scm (compute-instruction-arity):
* module/system/vm/disassembler.scm (unpack-s12, disassembler): Add
support for X8_S12_Z12.
* module/language/cps/types.scm (define-predicate-inferrer/param): New
helper.
(u64-=, u64-<, s64-<): Remove type checkers; this procedure does not
cause &type-check.
(u64-imm=?, s64-imm=?, u64-imm<?, imm-u64<?, s64-imm<?, imm-s64<?):
New type inferrers.
* module/language/cps/type-fold.scm (define-unary-branch-folder*): New
helper.
(u64-imm=?, s64-imm=?, u64-imm<?, imm-u64<?, s64-imm<?, imm-s64<?):
New branch folders.
* module/language/cps/reify-primitives.scm (reify-primitives): Reify
constants for new immediate branching primcalls if values out of
range.
* module/language/cps/effects-analysis.scm: Add support for new
primcalls.
* module/language/cps/compile-bytecode.scm (compile-function): Add
support for new primcalls and instructions. Compile u64-imm-= to
s64-imm=?.
---
libguile/instructions.c | 1 +
libguile/vm-engine.c | 76 ++++++++++++++++++++++++++++--
module/language/bytecode.scm | 1 +
module/language/cps/compile-bytecode.scm | 14 +++++-
module/language/cps/effects-analysis.scm | 6 +++
module/language/cps/primitives.scm | 1 -
module/language/cps/reify-primitives.scm | 41 +++++++++++++++-
module/language/cps/specialize-numbers.scm | 4 +-
module/language/cps/type-fold.scm | 28 ++++++++++-
module/language/cps/types.scm | 31 ++++++++++--
module/system/vm/assembler.scm | 33 ++++++++++++-
module/system/vm/disassembler.scm | 8 ++++
12 files changed, 225 insertions(+), 19 deletions(-)
diff --git a/libguile/instructions.c b/libguile/instructions.c
index a38035d..3d20a6b 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -40,6 +40,7 @@ SCM_SYMBOL (sym_bang, "!");
M(X8_S8_I16) \
M(X8_S12_S12) \
M(X8_S12_C12) \
+ M(X8_S12_Z12) \
M(X8_C12_C12) \
M(X8_F12_F12) \
M(X8_S8_S8_S8) \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index a70f78a..e07bf46 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -4100,11 +4100,77 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1);
}
- VM_DEFINE_OP (218, unused_218, NULL, NOP)
- VM_DEFINE_OP (219, unused_219, NULL, NOP)
- VM_DEFINE_OP (220, unused_220, NULL, NOP)
- VM_DEFINE_OP (221, unused_221, NULL, NOP)
- VM_DEFINE_OP (222, unused_222, NULL, NOP)
+ VM_DEFINE_OP (218, s64_imm_numerically_equal, "s64-imm=?", OP1 (X8_S12_Z12))
+ {
+ scm_t_uint16 a;
+ scm_t_int64 x, y;
+
+ a = (op >> 8) & 0xfff;
+ x = SP_REF_S64 (a);
+
+ y = ((scm_t_int32) op) >> 20; /* Sign extension. */
+
+ vp->compare_result = x == y ? SCM_F_COMPARE_EQUAL : SCM_F_COMPARE_NONE;
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (219, u64_imm_less, "u64-imm<?", OP1 (X8_S12_C12))
+ {
+ scm_t_uint16 a;
+ scm_t_uint64 x, y;
+
+ UNPACK_12_12 (op, a, y);
+ x = SP_REF_U64 (a);
+
+ vp->compare_result = x < y ? SCM_F_COMPARE_LESS_THAN :
SCM_F_COMPARE_NONE;
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (220, imm_u64_less, "imm-u64<?", OP1 (X8_S12_C12))
+ {
+ scm_t_uint16 a;
+ scm_t_uint64 x, y;
+
+ UNPACK_12_12 (op, a, x);
+ y = SP_REF_U64 (a);
+
+ vp->compare_result = x < y ? SCM_F_COMPARE_LESS_THAN :
SCM_F_COMPARE_NONE;
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (221, s64_imm_less, "s64-imm<?", OP1 (X8_S12_Z12))
+ {
+ scm_t_uint16 a;
+ scm_t_int64 x, y;
+
+ a = (op >> 8) & 0xfff;
+ x = SP_REF_S64 (a);
+
+ y = ((scm_t_int32) op) >> 20; /* Sign extension. */
+
+ vp->compare_result = x < y ? SCM_F_COMPARE_LESS_THAN :
SCM_F_COMPARE_NONE;
+
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (222, imm_s64_less, "imm-s64<?", OP1 (X8_S12_Z12))
+ {
+ scm_t_uint16 a;
+ scm_t_int64 x, y;
+
+ a = (op >> 8) & 0xfff;
+ y = SP_REF_S64 (a);
+
+ x = ((scm_t_int32) op) >> 20; /* Sign extension. */
+
+ vp->compare_result = x < y ? SCM_F_COMPARE_LESS_THAN :
SCM_F_COMPARE_NONE;
+
+ NEXT (1);
+ }
+
VM_DEFINE_OP (223, unused_223, NULL, NOP)
VM_DEFINE_OP (224, unused_224, NULL, NOP)
VM_DEFINE_OP (225, unused_225, NULL, NOP)
diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm
index 8372feb..b6be041 100644
--- a/module/language/bytecode.scm
+++ b/module/language/bytecode.scm
@@ -42,6 +42,7 @@
((X8_S8_I16) 2)
((X8_S12_S12) 2)
((X8_S12_C12) 2)
+ ((X8_S12_Z12) 2)
((X8_C12_C12) 2)
((X8_F12_F12) 2)
((X8_S8_S8_S8) 3)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 429f7e7..f11a4c1 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -425,6 +425,12 @@
(binary op emit-je emit-jne a b))
(define (binary-< emit-<? a b)
(binary emit-<? emit-jl emit-jnl a b))
+ (define (binary-test/imm op a b)
+ (op asm (from-sp (slot a)) b)
+ (emit-branch emit-je emit-jne))
+ (define (binary-</imm op a b)
+ (op asm (from-sp (slot a)) b)
+ (emit-branch emit-jl emit-jnl))
(match exp
(($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a))
(($ $primcall 'null? #f (a)) (unary emit-null? a))
@@ -451,9 +457,15 @@
(($ $primcall '< #f (a b)) (binary-< emit-<? a b))
(($ $primcall '= #f (a b)) (binary-test emit-=? a b))
(($ $primcall 'u64-< #f (a b)) (binary-< emit-u64<? a b))
+ (($ $primcall 'u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
+ (($ $primcall 'imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
(($ $primcall 'u64-= #f (a b)) (binary-test emit-u64=? a b))
+ (($ $primcall 'u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
+ (($ $primcall 's64-= #f (a b)) (binary-test emit-u64=? a b))
+ (($ $primcall 's64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
(($ $primcall 's64-< #f (a b)) (binary-< emit-s64<? a b))
- (($ $primcall 's64-= #f (a b)) (binary-test emit-s64=? a b))
+ (($ $primcall 's64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
+ (($ $primcall 'imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
(($ $primcall 'f64-< #f (a b)) (binary-< emit-f64<? a b))
(($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index dd24e73..178079e 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -424,9 +424,15 @@ is or might be a read or a write to the same location as
A."
((= . _) &type-check)
((< . _) &type-check)
((u64-= . _))
+ ((u64-imm-= . _))
((u64-< . _))
+ ((u64-imm-< . _))
+ ((imm-u64-< . _))
((s64-= . _))
+ ((s64-imm-= . _))
((s64-< . _))
+ ((s64-imm-< . _))
+ ((imm-s64-< . _))
((f64-= . _))
((f64-< . _))
((zero? . _) &type-check)
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index ed1492f..ed2aeae 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -139,7 +139,6 @@ before it is lowered to CPS?"
u64-=
s64-<
- s64-=
f64-<
f64-=))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 1c5b319..680c1b7 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -153,12 +153,13 @@
($continue kb src ($const b))))))
(($ $kargs names vars ($ $continue k src ($ $primcall name param args)))
(cond
- ((or (prim-instruction name) (branching-primitive? name))
+ ((prim-instruction name)
;; Assume arities are correct.
(let ()
(define (u6? val) (and (exact-integer? val) (<= 0 val 63)))
(define (u8? val) (and (exact-integer? val) (<= 0 val 255)))
- (define-syntax-rule (reify-constants wrap
+ (define-syntax-rule (reify-constants
+ wrap
((op (pred? c) in ...) (op* out ...))
...
(_ default))
@@ -211,6 +212,42 @@
($continue k src ($call proc args))))
(let$ body (resolve-prim name kproc src))
(setk label ($kargs names vars ,body))))))
+ (($ $kargs names vars
+ ($ $continue kf src ($ $branch kt ($ $primcall name param args))))
+ (let ()
+ (define (u11? val) (<= 0 val #x7ff))
+ (define (u12? val) (<= 0 val #xfff))
+ (define (s12? val) (<= (- #x800) val #x7ff))
+ (define-syntax-rule (reify-constants ((op (pred? c) in ...)
+ wrap-op (op* out ...))
+ ...
+ (_ default))
+ (match name
+ ('op
+ (if (pred? param)
+ cps
+ (match args
+ ((in ...)
+ (with-cps cps
+ (letv c)
+ (letk kconst
+ ($kargs ('c) (c)
+ ($continue kf src
+ ($branch kt ($primcall 'op* #f (out ...))))))
+ (setk label
+ ($kargs names vars
+ ($continue kconst src
+ ($primcall 'wrap-op param ())))))))))
+ ...
+ (_ default)))
+ (reify-constants
+ ((u64-imm-= (u11? b) a) load-u64 (u64-= a b))
+ ((u64-imm-< (u12? b) a) load-u64 (u64-< a b))
+ ((imm-u64-< (u12? a) b) load-u64 (u64-< a b))
+ ((s64-imm-= (s12? b) a) load-s64 (s64-= a b))
+ ((s64-imm-< (s12? b) a) load-s64 (s64-< a b))
+ ((imm-s64-< (s12? a) b) load-s64 (s64-< a b))
+ (_ cps))))
(($ $kargs names vars ($ $continue k src ($ $call proc args)))
(with-cps cps
(let$ k (uniquify-receive k))
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 37a1705..ced7a3b 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -203,7 +203,7 @@
($primcall unbox-a #f (scm))))))
(define (specialize-fixnum-comparison cps kf kt src op a b)
- (let ((op (symbol-append 's64- op)))
+ (let ((op (match op ('= 'u64-=) ('< 's64-<))))
(with-cps cps
(letv s64-a s64-b)
(letk kop ($kargs ('s64-b) (s64-b)
@@ -217,7 +217,7 @@
($primcall 'untag-fixnum #f (a)))))))
(define (specialize-fixnum-scm-comparison cps kf kt src op a-fx b-scm)
- (let ((s64-op (match op ('= 's64-=) ('< 's64-<))))
+ (let ((s64-op (match op ('= 'u64-=) ('< 's64-<))))
(with-cps cps
(letv a b sunk)
(letk kheap ($kargs ('sunk) (sunk)
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index 27b9dd8..4e8108f 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -51,9 +51,13 @@
(define-syntax-rule (define-branch-folder-alias to from)
(hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
-(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
+(define-syntax-rule (define-unary-branch-folder* (name param arg min max)
+ body ...)
(define-branch-folder name (lambda (param arg min max) body ...)))
+(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
+ (define-unary-branch-folder* (name param arg min max) body ...))
+
(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0
arg1 min1 max1)
body ...)
@@ -151,13 +155,33 @@
;;
;; (define-branch-folder-alias f64-< <)
+(define-unary-branch-folder* (u64-imm-= c type min max)
+ (cond
+ ((= c min max) (values #t #t))
+ ((<= min c max) (values #f #f))
+ (else (values #t #f))))
+(define-branch-folder-alias s64-imm-= u64-imm-=)
+
+(define-unary-branch-folder* (u64-imm-< c type min max)
+ (cond
+ ((< max c) (values #t #t))
+ ((>= min c) (values #t #f))
+ (else (values #f #f))))
+(define-branch-folder-alias s64-imm-< u64-imm-<)
+
+(define-unary-branch-folder* (imm-u64-< c type min max)
+ (cond
+ ((< c min) (values #t #t))
+ ((>= c max) (values #t #f))
+ (else (values #f #f))))
+(define-branch-folder-alias imm-s64-< imm-u64-<)
+
(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
(case (compare-integer-ranges type0 min0 max0 type1 min1 max1)
((=) (values #t #t))
((< >) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-= =)
-(define-branch-folder-alias s64-= =)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 7dcafd6..841d29f 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -471,6 +471,12 @@ minimum, and maximum."
(let ((true? (not (zero? succ))))
body ...)))
+(define-syntax-rule (define-predicate-inferrer/param
+ (name param arg ... true?) body ...)
+ (define-type-inferrer* (name param succ arg ...)
+ (let ((true? (not (zero? succ))))
+ body ...)))
+
(define-syntax define-simple-type-checker
(lambda (x)
(define (parse-spec l)
@@ -1007,16 +1013,31 @@ minimum, and maximum."
(define-simple-type-checker (< &real &real))
(define-<-inferrer (< &real &exact-integer))
-(define-simple-type-checker (u64-= &u64 &u64))
(define-=-inferrer (u64-= &u64))
-(define-simple-type-checker (u64-< &u64 &u64))
(define-<-inferrer (u64-< &u64 &u64))
-(define-simple-type-checker (s64-= &s64 &s64))
-(define-=-inferrer (s64-= &s64))
-(define-simple-type-checker (s64-< &s64 &s64))
(define-<-inferrer (s64-< &s64 &s64))
+(define-predicate-inferrer/param (u64-imm-= b a true?)
+ (when true?
+ (restrict! a (logior &u64 &s64) (max (&min a) b) (min (&max a) b))))
+
+(define-predicate-inferrer/param (u64-imm-< b a true?)
+ (if true?
+ (restrict! a (logior &u64 &s64) (&min a) (min (&max a) (1- b)))
+ (restrict! a (logior &u64 &s64) (max (&min a) b) (&max a))))
+
+(define-predicate-inferrer/param (imm-u64-< b a true?)
+ (if true?
+ (restrict! a (logior &u64 &s64) (max (1+ (&min a)) b) (&max a))
+ (restrict! a (logior &u64 &s64) (&min a) (min (&max a) b))))
+
+(define-type-aliases u64-imm-= s64-imm-=)
+(define-type-aliases u64-imm-< s64-imm-<)
+(define-type-aliases imm-u64-< imm-s64-<)
+
+
+
;; Unfortunately, we can't define f64 comparison inferrers because of
;; not-a-number values.
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 718ff5e..3fd5bba 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -66,8 +66,12 @@
emit-u64=?
emit-u64<?
- emit-s64=?
+ emit-u64-imm<?
+ emit-imm-u64<?
+ emit-s64-imm=?
emit-s64<?
+ emit-s64-imm<?
+ emit-imm-s64<?
emit-f64=?
emit-f64<?
emit-=?
@@ -341,6 +345,12 @@
(z (check-urange z #xfff)))
(logior x (ash y 8) (ash z 20))))
+(define-inline (pack-u8-u12-s12 x y z)
+ (let ((x (check-urange x #xff))
+ (y (check-urange y #xfff))
+ (z (check-srange z #xfff)))
+ (logior x (ash y 8) (ash z 20))))
+
(define-inline (pack-u8-u8-u16 x y z)
(let ((x (check-urange x #xff))
(y (check-urange y #xff))
@@ -617,6 +627,8 @@ later by the linker."
(emit asm (pack-u8-u12-u12 opcode a b)))
((X8_S12_C12 a b)
(emit asm (pack-u8-u12-u12 opcode a b)))
+ ((X8_S12_Z12 a b)
+ (emit asm (pack-u8-u12-s12 opcode a b)))
((X8_C12_C12 a b)
(emit asm (pack-u8-u12-u12 opcode a b)))
((X8_F12_F12 a b)
@@ -803,6 +815,14 @@ later by the linker."
(emit-push asm a)
(encode-X8_S12_S12-X8_C24 asm 0 0 const opcode)
(emit-pop asm dst))))
+(define (encode-X8_S12_C12!/shuffle asm a const opcode)
+ (cond
+ ((< a (ash 1 12))
+ (encode-X8_S12_C12 asm a const opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S12_C12 asm 0 const opcode)
+ (emit-drop asm 1))))
(define (encode-X8_S12_C12<-/shuffle asm dst const opcode)
(cond
((< dst (ash 1 12))
@@ -812,6 +832,14 @@ later by the linker."
(emit-push asm dst)
(encode-X8_S12_C12 asm 0 const opcode)
(emit-pop asm dst))))
+(define (encode-X8_S12_Z12!/shuffle asm a const opcode)
+ (cond
+ ((< a (ash 1 12))
+ (encode-X8_S12_Z12 asm a const opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S12_Z12 asm 0 const opcode)
+ (emit-drop asm 1))))
(define (encode-X8_S8_I16<-/shuffle asm dst imm opcode)
(cond
((< dst (ash 1 8))
@@ -877,7 +905,9 @@ later by the linker."
(('<- 'X8_S12_S12) #'encode-X8_S12_S12<-/shuffle)
(('! 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24!/shuffle)
(('<- 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24<-/shuffle)
+ (('! 'X8_S12_C12) #'encode-X8_S12_C12!/shuffle)
(('<- 'X8_S12_C12) #'encode-X8_S12_C12<-/shuffle)
+ (('! 'X8_S12_Z12) #'encode-X8_S12_Z12!/shuffle)
(('<- 'X8_S8_I16) #'encode-X8_S8_I16<-/shuffle)
(('! 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8!/shuffle)
(('<- 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8<-/shuffle)
@@ -919,6 +949,7 @@ later by the linker."
('X8_S8_I16 #'(a imm))
('X8_S12_S12 #'(a b))
('X8_S12_C12 #'(a b))
+ ('X8_S12_Z12 #'(a b))
('X8_C12_C12 #'(a b))
('X8_F12_F12 #'(a b))
('X8_S8_S8_S8 #'(a b c))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 89acf60..cb64479 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -72,6 +72,11 @@
s
(- s (ash 1 24))))
+(define (unpack-s12 s)
+ (if (zero? (logand s (ash 1 11)))
+ s
+ (- s (ash 1 12))))
+
(define (unpack-s32 s)
(if (zero? (logand s (ash 1 31)))
s
@@ -97,6 +102,9 @@
X8_F12_F12)
#'((logand (ash word -8) #xfff)
(ash word -20)))
+ ((X8_S12_Z12)
+ #'((logand (ash word -8) #xfff)
+ (unpack-s12 (ash word -20))))
((X8_S8_S8_S8
X8_S8_S8_C8
X8_S8_C8_S8)