From 25eee7be61f4e467a5ce83856fbf8a7770cf5dca Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 27 May 2018 21:58:48 -0400 Subject: [PATCH] Fix type inference for bitwise logical operators. Fixes and related bugs. Reported by Jan Nieuwenhuizen . * module/language/cps/types.scm (next-power-of-two): Remove procedure. (non-negative?, saturate+, saturate-, lognot*, logand-bounds): New procedures. Use them to improve and fix bugs in the range analysis of the type inferrers for 'logand', 'logsub', 'logior', 'ulogior', 'logxor', 'ulogxor', and 'lognot'. --- module/language/cps/types.scm | 158 +++++++++++++++++++++------------- 1 file changed, 97 insertions(+), 61 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index c24f9b99d..80073966d 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1,5 +1,5 @@ ;;; Type analysis on CPS -;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 2015, 2018 Free Software Foundation, Inc. ;;; ;;; This library is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU Lesser General Public License as @@ -1273,32 +1273,49 @@ minimum, and maximum." (define! result &u64 0 &u64-max))) (define-type-aliases ulsh ulsh/immediate) -(define (next-power-of-two n) - (let lp ((out 1)) - (if (< n out) - out - (lp (ash out 1))))) +(define-inlinable (non-negative? n) + (not (negative? n))) + +(define (saturate+ n) + (if (inf? n) + +inf.0 + (1- (ash 1 (integer-length n))))) + +(define (saturate- n) + (if (inf? n) + -inf.0 + (ash -1 (integer-length n)))) + +(define (lognot* n) + (- -1 n)) + +(define (logand-bounds a0 a1 b0 b1) + ;; (a0 <= a <= a1) and (b0 <= b <= b1) + (cond ((and (non-negative? a0) (non-negative? b0)) + (values 0 (min a1 b1))) + ((non-negative? a0) + (values 0 a1)) + ((non-negative? b0) + (values 0 b1)) + (else + (values (saturate- (min a0 b0)) + (cond ((and (negative? a1) (negative? b1)) + (min a1 b1)) + ((negative? a1) + b1) + ((negative? b1) + a1) + (else + (saturate+ (max a1 b1)))))))) (define-simple-type-checker (logand &exact-integer &exact-integer)) (define-type-inferrer (logand a b result) - (define (logand-min a b) - (if (and (negative? a) (negative? b)) - (let ((min (min a b))) - (if (inf? min) - -inf.0 - (- 1 (next-power-of-two (- min))))) - 0)) - (define (logand-max a b) - (cond - ((or (and (positive? a) (positive? b)) - (and (negative? a) (negative? b))) - (min a b)) - (else (max a b)))) (restrict! a &exact-integer -inf.0 +inf.0) (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (logand-min (&min a) (&min b)) - (logand-max (&max a) (&max b)))) + (call-with-values (lambda () + (logand-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define! result &exact-integer min max)))) (define-simple-type-checker (ulogand &u64 &u64)) (define-type-inferrer (ulogand a b result) @@ -1308,22 +1325,8 @@ minimum, and maximum." (define-simple-type-checker (logsub &exact-integer &exact-integer)) (define-type-inferrer (logsub a b result) - (define (logsub-bounds min-a max-a min-b max-b) - (cond - ((negative? max-b) - ;; Sign bit always set on B, so result will never be negative. - ;; If A might be negative (all leftmost bits 1), we don't know - ;; how positive the result might be. - (values 0 (if (negative? min-a) +inf.0 max-a))) - ((negative? min-b) - ;; Sign bit might be set on B. - (values min-a (if (negative? min-a) +inf.0 max-a))) - ((negative? min-a) - ;; Sign bit never set on B -- result will have the sign of A. - (values -inf.0 max-a)) - (else - ;; Sign bit never set on A and never set on B -- the nice case. - (values 0 max-a)))) + (define (logsub-bounds a0 a1 b0 b1) + (logand-bounds a0 a1 (lognot* b1) (lognot* b0))) (restrict! a &exact-integer -inf.0 +inf.0) (restrict! b &exact-integer -inf.0 +inf.0) (call-with-values (lambda () @@ -1339,24 +1342,30 @@ minimum, and maximum." (define-simple-type-checker (logior &exact-integer &exact-integer)) (define-type-inferrer (logior a b result) - ;; Saturate all bits of val. - (define (saturate val) - (1- (next-power-of-two val))) - (define (logior-min a b) - (cond ((and (< a 0) (<= 0 b)) a) - ((and (< b 0) (<= 0 a)) b) - (else (max a b)))) - (define (logior-max a b) - ;; If either operand is negative, just assume the max is -1. - (cond - ((or (< a 0) (< b 0)) -1) - ((or (inf? a) (inf? b)) +inf.0) - (else (saturate (logior a b))))) + (define (logior-bounds a0 a1 b0 b1) + ;; (a0 <= a <= a1) and (b0 <= b <= b1) + (cond ((and (negative? a1) (negative? b1)) + (values (max a0 b0) -1)) + ((negative? a1) + (values a0 -1)) + ((negative? b1) + (values b0 -1)) + (else + (values (cond ((and (non-negative? a0) (non-negative? b0)) + (max a0 b0)) + ((non-negative? a0) + b0) + ((non-negative? b0) + a0) + (else + (saturate- (min a0 b0)))) + (saturate+ (max a1 b1)))))) (restrict! a &exact-integer -inf.0 +inf.0) (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (logior-min (&min a) (&min b)) - (logior-max (&max a) (&max b)))) + (call-with-values (lambda () + (logior-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define! result &exact-integer min max)))) (define-simple-type-checker (ulogior &u64 &u64)) (define-type-inferrer (ulogior a b result) @@ -1364,23 +1373,50 @@ minimum, and maximum." (restrict! b &u64 0 &u64-max) (define! result &u64 (max (&min/0 a) (&min/0 b)) - (1- (next-power-of-two (logior (&max/u64 a) (&max/u64 b)))))) - -;; For our purposes, treat logxor the same as logior. -(define-type-aliases logior logxor) + (saturate+ (max (&max/u64 a) (&max/u64 b))))) + +(define-simple-type-checker (logxor &exact-integer &exact-integer)) +(define-type-inferrer (logxor a b result) + (define (logxor-bounds a0 a1 b0 b1) + ;; (a0 <= a <= a1) and (b0 <= b <= b1) + (cond ((and (non-negative? a0) (non-negative? b0)) + (values 0 (saturate+ (max a1 b1)))) + ((and (negative? a1) (negative? b1)) + (values 0 (saturate+ (min a0 b0)))) + ((and (non-negative? a0) (negative? b1)) + (values (saturate- (max a1 (lognot* b0))) -1)) + ((and (negative? a1) (non-negative? b0)) + (values (saturate- (max b1 (lognot* a0))) -1)) + ((and (negative? a0) (non-negative? a1) + (negative? b0) (non-negative? b1)) + (values (saturate- (max a1 b1 (lognot* a0) (lognot* b0))) + (saturate+ (max a1 b1 (lognot* a0) (lognot* b0))))) + (else + (values (if (and (non-negative? a1) (negative? b0)) + (saturate- (max a1 (lognot* b0))) + (saturate- (max b1 (lognot* a0)))) + (if (and (non-negative? a1) (non-negative? b1)) + (saturate+ (max a1 b1)) + (saturate+ (min a0 b0))))))) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (call-with-values (lambda () + (logxor-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define! result &exact-integer min max)))) (define-simple-type-checker (ulogxor &u64 &u64)) (define-type-inferrer (ulogxor a b result) (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) - (define! result &u64 0 &u64-max)) + (define! result &u64 0 (saturate+ (max (&max/u64 a) (&max/u64 b))))) (define-simple-type-checker (lognot &exact-integer)) (define-type-inferrer (lognot a result) (restrict! a &exact-integer -inf.0 +inf.0) (define! result &exact-integer - (- -1 (&max a)) - (- -1 (&min a)))) + (lognot* (&max a)) + (lognot* (&min a)))) (define-simple-type-checker (logtest &exact-integer &exact-integer)) (define-predicate-inferrer (logtest a b true?) -- 2.17.0