diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index e7994cd32..d615af1aa 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3402,9 +3402,48 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, BR_U64_ARITHMETIC (<=, scm_leq_p); } - VM_DEFINE_OP (149, unused_149, NULL, NOP) - VM_DEFINE_OP (150, unused_150, NULL, NOP) - VM_DEFINE_OP (151, unused_151, NULL, NOP) + /* uadd dst:8 a:8 b:8 + * + * Add A to B, and place the result in DST. The operands and the + * result are unboxed unsigned 64-bit integers. Overflow will wrap + * around. + */ + VM_DEFINE_OP (149, uadd, "uadd", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_U64 (dst, SP_REF_U64 (a) + SP_REF_U64 (b)); + NEXT (1); + } + + /* usub dst:8 a:8 b:8 + * + * Subtract B from A, and place the result in DST. The operands and + * the result are unboxed unsigned 64-bit integers. Overflow will + * wrap around. + */ + VM_DEFINE_OP (150, usub, "usub", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_U64 (dst, SP_REF_U64 (a) - SP_REF_U64 (b)); + NEXT (1); + } + + /* umul dst:8 a:8 b:8 + * + * Multiply A and B, and place the result in DST. The operands and + * the result are unboxed unsigned 64-bit integers. Overflow will + * wrap around. + */ + VM_DEFINE_OP (151, umul, "umul", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_U64 (dst, SP_REF_U64 (a) * SP_REF_U64 (b)); + 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) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index fc8229386..9112c429b 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -425,6 +425,9 @@ is or might be a read or a write to the same location as A." ((fsub . _)) ((fmul . _)) ((fdiv . _)) + ((uadd . _)) + ((usub . _)) + ((umul . _)) ((sub1 . _) &type-check) ((add1 . _) &type-check) ((quo . _) &type-check) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index e54078027..e8519f0fa 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -793,7 +793,8 @@ are comparable with eqv?. A tmp slot may be used." (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) - (($ $primcall (or 'scm->u64 'bv-length)) + (($ $primcall (or 'scm->u64 'bv-length + 'uadd 'usub 'umul)) (intmap-add representations var 'u64)) (_ (intmap-add representations var 'scm)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 81d2eb1eb..41d4f562c 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -916,6 +916,7 @@ minimum, and maximum." (define-simple-type-checker (add &number &number)) (define-type-checker (fadd a b) #t) +(define-type-checker (uadd a b) #t) (define-type-inferrer (add a b result) (define-binary-result! a b result #t (+ (&min a) (&min b)) @@ -924,9 +925,16 @@ minimum, and maximum." (define! result &f64 (+ (&min a) (&min b)) (+ (&max a) (&max b)))) +(define-type-inferrer (uadd a b result) + ;; Handle wraparound. + (let ((max (+ (&max a) (&max b)))) + (if (<= max #xffffffffffffffff) + (define! result &u64 (+ (&min a) (&min b)) max) + (define! result &u64 0 #xffffffffffffffff)))) (define-simple-type-checker (sub &number &number)) (define-type-checker (fsub a b) #t) +(define-type-checker (usub a b) #t) (define-type-inferrer (sub a b result) (define-binary-result! a b result #t (- (&min a) (&max b)) @@ -935,9 +943,16 @@ minimum, and maximum." (define! result &f64 (- (&min a) (&max b)) (- (&max a) (&min b)))) +(define-type-inferrer (usub a b result) + ;; Handle wraparound. + (let ((min (- (&min a) (&max b)))) + (if (< min 0) + (define! result &u64 0 #xffffffffffffffff) + (define! result &u64 min (- (&max a) (&min b)))))) (define-simple-type-checker (mul &number &number)) (define-type-checker (fmul a b) #t) +(define-type-checker (umul a b) #t) (define (mul-result-range same? nan-impossible? min-a max-a min-b max-b) (define (nan* a b) (if (and (or (and (inf? a) (zero? b)) @@ -980,6 +995,12 @@ minimum, and maximum." min-a max-a min-b max-b)) (lambda (min max) (define! result &f64 min max))))) +(define-type-inferrer (umul a b result) + ;; Handle wraparound. + (let ((max (* (&max a) (&max b)))) + (if (<= max #xffffffffffffffff) + (define! result &u64 (* (&min a) (&min b)) max) + (define! result &u64 0 #xffffffffffffffff)))) (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 0ee391822..76ae892a3 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -142,6 +142,9 @@ (emit-fsub* . emit-fsub) (emit-fmul* . emit-fmul) (emit-fdiv* . emit-fdiv) + (emit-uadd* . emit-uadd) + (emit-usub* . emit-usub) + (emit-umul* . emit-umul) (emit-logand* . emit-logand) (emit-logior* . emit-logior) (emit-logxor* . emit-logxor)