diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 8 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 4 | ||||
-rw-r--r-- | module/language/cps/specialize-numbers.scm | 130 | ||||
-rw-r--r-- | module/language/cps/type-fold.scm | 5 | ||||
-rw-r--r-- | module/language/cps/types.scm | 40 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 7 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 4 |
7 files changed, 166 insertions, 32 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 43c6d7133..2b5d7591a 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -192,6 +192,14 @@ (emit-usub/immediate asm (from-sp dst) (from-sp (slot x)) y)) (($ $primcall 'umul/immediate y (x)) (emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) y)) + (($ $primcall 'rsh (x y)) + (emit-rsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y)))) + (($ $primcall 'lsh (x y)) + (emit-lsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y)))) + (($ $primcall 'rsh/immediate y (x)) + (emit-rsh/immediate asm (from-sp dst) (from-sp (slot x)) y)) + (($ $primcall 'lsh/immediate y (x)) + (emit-lsh/immediate asm (from-sp dst) (from-sp (slot x)) y)) (($ $primcall 'ursh/immediate y (x)) (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) y)) (($ $primcall 'ulsh/immediate y (x)) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index e3dacaf9c..7679c7ee3 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -470,6 +470,10 @@ is or might be a read or a write to the same location as A." ((even? _) &type-check) ((odd? _) &type-check) ((ash n m) &type-check) + ((rsh n m) &type-check) + ((lsh n m) &type-check) + ((rsh/immediate n) &type-check) + ((lsh/immediate n) &type-check) ((logand . _) &type-check) ((logior . _) &type-check) ((logxor . _) &type-check) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index aa08c8ff9..9daa78a3a 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -61,6 +61,46 @@ #:use-module (language cps with-cps) #:export (specialize-numbers)) +(define (specialize-f64-unop cps k src op a b) + (cond + ((eq? op 'sub/immediate) + (specialize-f64-unop cps k src 'add/immediate a (- b))) + (else + (let ((fop (match op + ('add/immediate 'fadd/immediate) + ('mul/immediate 'fmul/immediate)))) + (with-cps cps + (letv f64-a result) + (letk kbox ($kargs ('result) (result) + ($continue k src + ($primcall 'f64->scm #f (result))))) + (letk kop ($kargs ('f64-a) (f64-a) + ($continue kbox src + ($primcall fop b (f64-a))))) + (build-term + ($continue kop src + ($primcall 'scm->f64 #f (a))))))))) + +(define* (specialize-u64-unop cps k src op a b #:key + (unbox-a 'scm->u64)) + (let ((uop (match op + ('add/immediate 'uadd/immediate) + ('sub/immediate 'usub/immediate) + ('mul/immediate 'umul/immediate) + ('rsh/immediate 'ursh/immediate) + ('lsh/immediate 'ulsh/immediate)))) + (with-cps cps + (letv u64-a result) + (letk kbox ($kargs ('result) (result) + ($continue k src + ($primcall 'u64->scm #f (result))))) + (letk kop ($kargs ('u64-a) (u64-a) + ($continue kbox src + ($primcall uop b (u64-a))))) + (build-term + ($continue kop src + ($primcall unbox-a #f (a))))))) + (define (specialize-f64-binop cps k src op a b) (let ((fop (match op ('add 'fadd) @@ -92,9 +132,7 @@ ('logand 'ulogand) ('logior 'ulogior) ('logxor 'ulogxor) - ('logsub 'ulogsub) - ('rsh 'ursh) - ('lsh 'ulsh)))) + ('logsub 'ulogsub)))) (with-cps cps (letv u64-a u64-b result) (letk kbox ($kargs ('result) (result) @@ -110,6 +148,23 @@ ($continue kunbox-b src ($primcall unbox-a #f (a))))))) +(define* (specialize-u64-shift cps k src op a b #:key + (unbox-a 'scm->u64)) + (let ((uop (match op + ('rsh 'ursh) + ('lsh 'ulsh)))) + (with-cps cps + (letv u64-a result) + (letk kbox ($kargs ('result) (result) + ($continue k src + ($primcall 'u64->scm #f (result))))) + (letk kop ($kargs ('u64-a) (u64-a) + ($continue kbox src + ($primcall uop #f (u64-a b))))) + (build-term + ($continue kop src + ($primcall unbox-a #f (a))))))) + (define (truncate-u64 cps k src scm) (with-cps cps (letv u64) @@ -358,6 +413,35 @@ BITS indicating the significant bits needed for a variable. BITS may be types sigbits)))))) (($ $kargs names vars + ($ $continue k src + ($ $primcall (and op + (or 'add/immediate 'sub/immediate + 'mul/immediate + 'rsh/immediate 'lsh/immediate)) + b (a)))) + (match (intmap-ref cps k) + (($ $kargs (_) (result)) + (call-with-values (lambda () + (lookup-post-type types label result 0)) + (lambda (type min max) + (values + (cond + ((eqv? type &flonum) + (with-cps cps + (let$ body (specialize-f64-unop k src op a b)) + (setk label ($kargs names vars ,body)))) + ((and (type<=? type &exact-integer) + (or (<= 0 min max #xffffffffffffffff) + (only-u64-bits-used? result)) + (u64-operand? a) (<= 0 b #xffffFFFFffffFFFF)) + (with-cps cps + (let$ body (specialize-u64-unop k src op a b)) + (setk label ($kargs names vars ,body)))) + (else + cps)) + types + sigbits)))))) + (($ $kargs names vars ($ $continue k src ($ $primcall 'ash #f (a b)))) (match (intmap-ref cps k) (($ $kargs (_) (result)) @@ -373,28 +457,40 @@ BITS indicating the significant bits needed for a variable. BITS may be (<= b-min -64) (<= 64 b-max)) cps) - ((and (< b-min 0) (= b-min b-max)) - (with-cps cps - (let$ body - (with-cps-constants ((bits (- b-min))) - ($ (specialize-u64-binop k src 'rsh a bits)))) - (setk label ($kargs names vars ,body)))) + ((= b-min b-max) + (if (< b-min 0) + (with-cps cps + (let$ body + (specialize-u64-unop k src + 'rsh/immediate a (- b-min))) + (setk label ($kargs names vars ,body))) + (with-cps cps + (let$ body + (specialize-u64-unop k src + 'lsh/immediate a b-min)) + (setk label ($kargs names vars ,body))))) ((< b-min 0) (with-cps cps (let$ body (with-cps-constants ((zero 0)) - (letv bits) + (letv count ucount) (let$ body - (specialize-u64-binop k src 'rsh a bits)) - (letk kneg ($kargs ('bits) (bits) ,body)) - (build-term - ($continue kneg src - ($primcall 'sub #f (zero b)))))) + (specialize-u64-shift k src 'rsh a ucount)) + (letk kucount ($kargs ('ucount) (ucount) ,body)) + (letk kcount ($kargs ('count) (count) + ($continue kucount src + ($primcall 'scm->u64 #f (count))))) + (build-term ($continue kcount src + ($primcall 'sub #f (zero b)))))) (setk label ($kargs names vars ,body)))) (else (with-cps cps - (let$ body (specialize-u64-binop k src 'lsh a b)) - (setk label ($kargs names vars ,body))))) + (letv ucount) + (let$ body (specialize-u64-shift k src 'lsh a ucount)) + (letk kunbox ($kargs ('ucount) (ucount) ,body)) + (setk label ($kargs names vars + ($continue kunbox src + ($primcall 'scm->u64 #f (b)))))))) types sigbits)))))) (($ $kargs names vars diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index ce280b96c..fdbefaeb1 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -231,8 +231,7 @@ (let ((n (let lp ((bits 0) (constant constant)) (if (= constant 1) bits (lp (1+ bits) (ash constant -1)))))) (with-cps cps - ($ (with-cps-constants ((bits n)) - (build-term ($continue k src ($primcall 'ash #f (arg bits))))))))) + (build-term ($continue k src ($primcall 'lsh/immediate n (arg))))))) (define (mul/constant constant constant-type arg arg-type) (cond ((not (or (type<=? constant-type &exact-integer) @@ -255,7 +254,7 @@ ((and (type<=? (logior constant-type arg-type) &exact-integer) (positive? constant) (zero? (logand constant (1- constant)))) - ;; (* arg power-of-2) -> (ash arg (log2 power-of-2 + ;; (* arg power-of-2) -> (ash arg (log2 power-of-2)) (power-of-two constant arg)) (else (fail)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 4a764fb10..9561d6d92 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1372,25 +1372,45 @@ minimum, and maximum." ;; Bit operations. (define-simple-type-checker (ash &exact-integer &exact-integer)) -(define-type-inferrer (ash val count result) +(define-simple-type-checker (lsh &exact-integer &u64)) +(define-simple-type-checker (rsh &exact-integer &u64)) +(define (compute-ash-range min-val max-val min-shift max-shift) (define (ash* val count) ;; As we only precisely represent a 64-bit range, don't bother inferring ;; shifts that might exceed that range. (cond ((inf? val) val) ; Preserves sign. - ((< -64 count 64) (ash val count)) + ((< count 64) (ash val (max count 0))) ((zero? val) 0) ((positive? val) +inf.0) (else -inf.0))) + (let ((-- (ash* min-val min-shift)) + (-+ (ash* min-val max-shift)) + (++ (ash* max-val max-shift)) + (+- (ash* max-val min-shift))) + (values (min -- -+ ++ +-) (max -- -+ ++ +-)))) +(define-type-inferrer (ash val count result) (restrict! val &exact-integer -inf.0 +inf.0) (restrict! count &exact-integer -inf.0 +inf.0) - (let ((-- (ash* (&min val) (&min count))) - (-+ (ash* (&min val) (&max count))) - (++ (ash* (&max val) (&max count))) - (+- (ash* (&max val) (&min count)))) - (define-exact-integer! result - (min -- -+ ++ +-) - (max -- -+ ++ +-)))) + (let-values (((min max) (compute-ash-range (&min val) + (&max val) + (&min count) + (&max count)))) + (define-exact-integer! result min max))) +(define-type-inferrer (lsh val count result) + (restrict! val &exact-integer -inf.0 +inf.0) + (let-values (((min max) (compute-ash-range (&min val) + (&max val) + (&min/0 count) + (&max/u64 count)))) + (define-exact-integer! result min max))) +(define-type-inferrer (rsh val count result) + (restrict! val &exact-integer -inf.0 +inf.0) + (let-values (((min max) (compute-ash-range (&min val) + (&max val) + (- (&min/0 count)) + (- (&max/u64 count))))) + (define-exact-integer! result min max))) (define-simple-type-checker (ursh &u64 &u64)) (define-type-inferrer (ursh a b result) @@ -1404,8 +1424,6 @@ minimum, and maximum." (define-simple-type-checker (ulsh &u64 &u64)) (define-type-inferrer (ulsh a b result) - (restrict! a &u64 0 &u64-max) - (restrict! b &u64 0 &u64-max) (if (and (< (&max/u64 b) 64) (<= (ash (&max/u64 a) (&max/u64 b)) &u64-max)) ;; No overflow; we can be precise. diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 6835ce08e..a242da99d 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -669,7 +669,8 @@ ... (_ def))) (define (uint? val) (and (exact-integer? val) (<= 0 val))) - ;; FIXME: Add cases for mul, rsh, lsh + (define (negint? val) (and (exact-integer? val) (< val 0))) + ;; FIXME: Add case for mul (specialize-case (('make-vector ($ <const> _ (? uint? n)) init) (make-vector/immediate n (init))) @@ -689,6 +690,10 @@ (add/immediate y (x))) (('sub x ($ <const> _ (? number? y))) (sub/immediate y (x))) + (('ash x ($ <const> _ (? uint? y))) + (lsh/immediate y (x))) + (('ash x ($ <const> _ (? negint? y))) + (rsh/immediate (- y) (x))) (_ (default)))) (when (branching-primitive? name) (error "branching primcall in bad context" name)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 1f2189159..67ef7676a 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -189,6 +189,10 @@ emit-rem emit-mod emit-ash + emit-lsh + emit-rsh + emit-lsh/immediate + emit-rsh/immediate emit-fadd emit-fsub emit-fmul |