summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libguile/vm-engine.c102
-rw-r--r--module/language/cps/compile-bytecode.scm13
-rw-r--r--module/language/cps/effects-analysis.scm5
-rw-r--r--module/language/cps/optimize.scm4
-rw-r--r--module/language/cps/slot-allocation.scm7
-rw-r--r--module/language/cps/specialize-primcalls.scm31
-rw-r--r--module/language/cps/types.scm5
-rw-r--r--module/system/vm/assembler.scm5
8 files changed, 153 insertions, 19 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 80ab3afd8..2f3b3fd85 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2382,7 +2382,29 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
BINARY_INTEGER_OP (+, scm_sum);
}
- VM_DEFINE_OP (87, unused_87, NULL, NOP)
+ /* add/immediate dst:8 src:8 imm:8
+ *
+ * Add the unsigned 8-bit value IMM to the value from SRC, and place
+ * the result in DST.
+ */
+ VM_DEFINE_OP (87, add_immediate, "add/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+ {
+ scm_t_uint8 dst, src, imm;
+ SCM x;
+
+ UNPACK_8_8_8 (op, dst, src, imm);
+ x = SP_REF (src);
+
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_signed_bits sum = SCM_I_INUM (x) + (scm_t_signed_bits) imm;
+
+ if (SCM_LIKELY (SCM_POSFIXABLE (sum)))
+ RETURN (SCM_I_MAKINUM (sum));
+ }
+
+ RETURN_EXP (scm_sum (x, SCM_I_MAKINUM (imm)));
+ }
/* sub dst:8 a:8 b:8
*
@@ -2393,7 +2415,29 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
BINARY_INTEGER_OP (-, scm_difference);
}
- VM_DEFINE_OP (89, unused_89, NULL, NOP)
+ /* sub/immediate dst:8 src:8 imm:8
+ *
+ * Subtract the unsigned 8-bit value IMM from the value in SRC, and
+ * place the result in DST.
+ */
+ VM_DEFINE_OP (89, sub_immediate, "sub/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+ {
+ scm_t_uint8 dst, src, imm;
+ SCM x;
+
+ UNPACK_8_8_8 (op, dst, src, imm);
+ x = SP_REF (src);
+
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ scm_t_signed_bits diff = SCM_I_INUM (x) - (scm_t_signed_bits) imm;
+
+ if (SCM_LIKELY (SCM_NEGFIXABLE (diff)))
+ RETURN (SCM_I_MAKINUM (diff));
+ }
+
+ RETURN_EXP (scm_difference (x, SCM_I_MAKINUM (imm)));
+ }
/* mul dst:8 a:8 b:8
*
@@ -3400,9 +3444,57 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1);
}
- VM_DEFINE_OP (152, unused_152, NULL, NOP)
- VM_DEFINE_OP (153, unused_153, NULL, NOP)
- VM_DEFINE_OP (154, unused_154, NULL, NOP)
+ /* uadd/immediate dst:8 src:8 imm:8
+ *
+ * Add the unsigned 64-bit value from SRC with the unsigned 8-bit
+ * value IMM and place the raw unsigned 64-bit result in DST.
+ * Overflow will wrap around.
+ */
+ VM_DEFINE_OP (152, uadd_immediate, "uadd/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+ {
+ scm_t_uint8 dst, src, imm;
+ scm_t_uint64 x;
+
+ UNPACK_8_8_8 (op, dst, src, imm);
+ x = SP_REF_U64 (src);
+ SP_SET_U64 (dst, x + (scm_t_uint64) imm);
+ NEXT (1);
+ }
+
+ /* usub/immediate dst:8 src:8 imm:8
+ *
+ * Subtract the unsigned 8-bit value IMM from the unsigned 64-bit
+ * value in SRC and place the raw unsigned 64-bit result in DST.
+ * Overflow will wrap around.
+ */
+ VM_DEFINE_OP (153, usub_immediate, "usub/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+ {
+ scm_t_uint8 dst, src, imm;
+ scm_t_uint64 x;
+
+ UNPACK_8_8_8 (op, dst, src, imm);
+ x = SP_REF_U64 (src);
+ SP_SET_U64 (dst, x - (scm_t_uint64) imm);
+ NEXT (1);
+ }
+
+ /* umul/immediate dst:8 src:8 imm:8
+ *
+ * Multiply the unsigned 64-bit value from SRC by the unsigned 8-bit
+ * value IMM and place the raw unsigned 64-bit result in DST.
+ * Overflow will wrap around.
+ */
+ VM_DEFINE_OP (154, umul_immediate, "umul/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
+ {
+ scm_t_uint8 dst, src, imm;
+ scm_t_uint64 x;
+
+ UNPACK_8_8_8 (op, dst, src, imm);
+ x = SP_REF_U64 (src);
+ SP_SET_U64 (dst, x * (scm_t_uint64) imm);
+ NEXT (1);
+ }
+
VM_DEFINE_OP (155, unused_155, NULL, NOP)
VM_DEFINE_OP (156, unused_156, NULL, NOP)
VM_DEFINE_OP (157, unused_157, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 2a6370c25..9dfee572a 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -179,6 +179,19 @@
(($ $primcall 'struct-ref/immediate (struct n))
(emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
(constant n)))
+ (($ $primcall 'add/immediate (x y))
+ (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
+ (($ $primcall 'sub/immediate (x y))
+ (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
+ (($ $primcall 'uadd/immediate (x y))
+ (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x))
+ (constant y)))
+ (($ $primcall 'usub/immediate (x y))
+ (emit-usub/immediate asm (from-sp dst) (from-sp (slot x))
+ (constant y)))
+ (($ $primcall 'umul/immediate (x y))
+ (emit-umul/immediate asm (from-sp dst) (from-sp (slot x))
+ (constant y)))
(($ $primcall 'builtin-ref (name))
(emit-builtin-ref asm (from-sp dst) (constant name)))
(($ $primcall 'scm->f64 (src))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 21df42ccd..43ec1b037 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -418,8 +418,10 @@ is or might be a read or a write to the same location as A."
((u64->= . _))
((zero? . _) &type-check)
((add . _) &type-check)
+ ((add/immediate . _) &type-check)
((mul . _) &type-check)
((sub . _) &type-check)
+ ((sub/immediate . _) &type-check)
((div . _) &type-check)
((fadd . _))
((fsub . _))
@@ -428,6 +430,9 @@ is or might be a read or a write to the same location as A."
((uadd . _))
((usub . _))
((umul . _))
+ ((uadd/immediate . _))
+ ((usub/immediate . _))
+ ((umul/immediate . _))
((quo . _) &type-check)
((rem . _) &type-check)
((mod . _) &type-check)
diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index 7d4dc2fe2..707b68d4e 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -94,7 +94,6 @@
(simplify #:simplify? #t)
(contify #:contify? #t)
(inline-constructors #:inline-constructors? #t)
- (specialize-primcalls #:specialize-primcalls? #t)
(elide-values #:elide-values? #t)
(prune-bailouts #:prune-bailouts? #t)
(peel-loops #:peel-loops? #t)
@@ -110,7 +109,8 @@
(eliminate-common-subexpressions #:cse? #t)
(eliminate-dead-code #:eliminate-dead-code? #t)
(rotate-loops #:rotate-loops? #t)
- (simplify #:simplify? #t))
+ (simplify #:simplify? #t)
+ (specialize-primcalls #:specialize-primcalls? #t))
(define (cps-default-optimization-options)
(list ;; #:split-rec? #t
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index e8519f0fa..d41013f28 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -347,6 +347,10 @@ the definitions that are live before and after LABEL, as intsets."
(defs+ s))
(($ $primcall 'struct-set!/immediate (s n x))
(defs+* (intset s x)))
+ (($ $primcall (or 'add/immediate 'sub/immediate
+ 'uadd/immediate 'usub/immediate 'umul/immediate)
+ (x y))
+ (defs+ x))
(($ $primcall 'builtin-ref (idx))
defs)
(_
@@ -794,7 +798,8 @@ are comparable with eqv?. A tmp slot may be used."
'fadd 'fsub 'fmul 'fdiv))
(intmap-add representations var 'f64))
(($ $primcall (or 'scm->u64 'bv-length
- 'uadd 'usub 'umul))
+ 'uadd 'usub 'umul
+ 'uadd/immediate 'usub/immediate 'umul/immediate))
(intmap-add representations var 'u64))
(_
(intmap-add representations var 'scm))))
diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm
index c15fbdb3b..0c234eed3 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -33,27 +33,36 @@
(define (specialize-primcalls conts)
(let ((constants (compute-constant-values conts)))
- (define (immediate-u8? var)
+ (define (u8? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (exact-integer? val) (<= 0 val 255))))
(define (specialize-primcall name args)
+ (define (rename name)
+ (build-exp ($primcall name args)))
(match (cons name args)
- (('make-vector (? immediate-u8? n) init) 'make-vector/immediate)
- (('vector-ref v (? immediate-u8? n)) 'vector-ref/immediate)
- (('vector-set! v (? immediate-u8? n) x) 'vector-set!/immediate)
- (('allocate-struct v (? immediate-u8? n)) 'allocate-struct/immediate)
- (('struct-ref s (? immediate-u8? n)) 'struct-ref/immediate)
- (('struct-set! s (? immediate-u8? n) x) 'struct-set!/immediate)
+ (('make-vector (? u8? n) init) (rename 'make-vector/immediate))
+ (('vector-ref v (? u8? n)) (rename 'vector-ref/immediate))
+ (('vector-set! v (? u8? n) x) (rename 'vector-set!/immediate))
+ (('allocate-struct v (? u8? n)) (rename 'allocate-struct/immediate))
+ (('struct-ref s (? u8? n)) (rename 'struct-ref/immediate))
+ (('struct-set! s (? u8? n) x) (rename 'struct-set!/immediate))
+ (('add x (? u8? y)) (build-exp ($primcall 'add/immediate (x y))))
+ (('add (? u8? x) y) (build-exp ($primcall 'add/immediate (y x))))
+ (('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate (x y))))
+ (('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate (x y))))
+ (('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate (y x))))
+ (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y))))
+ (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y))))
+ (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x))))
(_ #f)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall name args)))
- (let ((name* (specialize-primcall name args)))
- (if name*
+ (let ((exp* (specialize-primcall name args)))
+ (if exp*
(build-cont
- ($kargs names vars
- ($continue k src ($primcall name* args))))
+ ($kargs names vars ($continue k src ,exp*)))
cont)))
(_ cont)))
conts)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 1a0eebbe1..6928589da 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -933,6 +933,7 @@ minimum, and maximum."
min* max*))))))
(define-simple-type-checker (add &number &number))
+(define-type-aliases add add/immediate)
(define-type-checker (fadd a b) #t)
(define-type-checker (uadd a b) #t)
(define-type-inferrer (add a b result)
@@ -949,8 +950,10 @@ minimum, and maximum."
(if (<= max #xffffffffffffffff)
(define! result &u64 (+ (&min a) (&min b)) max)
(define! result &u64 0 #xffffffffffffffff))))
+(define-type-aliases uadd uadd/immediate)
(define-simple-type-checker (sub &number &number))
+(define-type-aliases sub sub/immediate)
(define-type-checker (fsub a b) #t)
(define-type-checker (usub a b) #t)
(define-type-inferrer (sub a b result)
@@ -967,6 +970,7 @@ minimum, and maximum."
(if (< min 0)
(define! result &u64 0 #xffffffffffffffff)
(define! result &u64 min (- (&max a) (&min b))))))
+(define-type-aliases usub usub/immediate)
(define-simple-type-checker (mul &number &number))
(define-type-checker (fmul a b) #t)
@@ -1019,6 +1023,7 @@ minimum, and maximum."
(if (<= max #xffffffffffffffff)
(define! result &u64 (* (&min a) (&min b)) max)
(define! result &u64 0 #xffffffffffffffff))))
+(define-type-aliases umul umul/immediate)
(define-type-checker (div a b)
(and (check-type a &number -inf.0 +inf.0)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 9dcd6dc79..07333112f 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -129,7 +129,9 @@
(emit-set-car!* . emit-set-car!)
(emit-set-cdr!* . emit-set-cdr!)
(emit-add* . emit-add)
+ (emit-add/immediate* . emit-add/immediate)
(emit-sub* . emit-sub)
+ (emit-sub/immediate* . emit-sub/immediate)
(emit-mul* . emit-mul)
(emit-div* . emit-div)
(emit-quo* . emit-quo)
@@ -143,6 +145,9 @@
(emit-uadd* . emit-uadd)
(emit-usub* . emit-usub)
(emit-umul* . emit-umul)
+ (emit-uadd/immediate* . emit-uadd/immediate)
+ (emit-usub/immediate* . emit-usub/immediate)
+ (emit-umul/immediate* . emit-umul/immediate)
(emit-logand* . emit-logand)
(emit-logior* . emit-logior)
(emit-logxor* . emit-logxor)
generated by cgit v1.2.3 (git 2.46.0) at 2024-11-21 23:54:23 +0000