diff options
author | Andy Wingo <wingo@pobox.com> | 2017-11-14 10:41:24 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-11-15 14:18:39 +0100 |
commit | 294dbaad35e139427ecbfffa7b02f0a2ee037b9b (patch) | |
tree | 33147ae03d436aab390dbb0314694f809c717a48 | |
parent | 4a0a930f1c6f3d34bbd5bd9877042de368b9c196 (diff) | |
download | guile-294dbaad35e139427ecbfffa7b02f0a2ee037b9b.tar.gz |
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=?.
-rw-r--r-- | libguile/instructions.c | 1 | ||||
-rw-r--r-- | libguile/vm-engine.c | 76 | ||||
-rw-r--r-- | module/language/bytecode.scm | 1 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 14 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 6 | ||||
-rw-r--r-- | module/language/cps/primitives.scm | 1 | ||||
-rw-r--r-- | module/language/cps/reify-primitives.scm | 41 | ||||
-rw-r--r-- | module/language/cps/specialize-numbers.scm | 4 | ||||
-rw-r--r-- | module/language/cps/type-fold.scm | 28 | ||||
-rw-r--r-- | module/language/cps/types.scm | 31 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 33 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 8 |
12 files changed, 225 insertions, 19 deletions
diff --git a/libguile/instructions.c b/libguile/instructions.c index a38035d25..3d20a6be8 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 a70f78a1c..e07bf46e5 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 8372feb02..b6be04178 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 429f7e777..f11a4c1ad 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 dd24e7398..178079e79 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 ed1492fc3..ed2aeaedf 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 1c5b31949..680c1b771 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 37a17057c..ced7a3b3b 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 27b9dd827..4e8108fbb 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 7dcafd663..841d29f28 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 718ff5ea2..3fd5bba79 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 89acf6090..cb6447901 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) |