From: Taylor R Campbell <campbell@mumble.net>
Date: Tue, 30 Oct 2018 15:59:04 +0000 (+0000)
Subject: Mask underflow exception in logsumexp because it doesn't matter.
X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~132
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8f61ad84fc7d2c5e3145ce197617fc2a4a48f5d7;p=mit-scheme.git

Mask underflow exception in logsumexp because it doesn't matter.
---

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index a129257fd..14dd4a00e 100644
--- a/src/runtime/arith.scm
+++ b/src/runtime/arith.scm
@@ -2064,7 +2064,18 @@ USA.
 		     (not (= (- m) (reduce min #f l)))
 		     (not (any nan? l)))
 		m
-		(+ m (log (reduce + 0 (map (lambda (x) (exp (- x m))) l))))))
+		;; Overflow is not possible because everything is
+		;; normalized to be below zero.  Underflow can be
+		;; safely ignored because it can't change the outcome:
+		;; even if you had 2^64 copies of the largest subnormal
+		;; in the sum, 2^64 * largest subnormal < 2^900 <<<
+		;; epsilon = 2^-53, and at least one addend in the sum
+		;; is 1.
+		(flo:with-exceptions-untrapped (flo:exception:underflow)
+		  (lambda ()
+		    (+ m
+		       (log
+			(reduce + 0 (map (lambda (x) (exp (- x m))) l))))))))
 	  (car l))
       (flo:-inf.0)))
 
diff --git a/tests/runtime/test-arith.scm b/tests/runtime/test-arith.scm
index ebce10c03..523736357 100644
--- a/tests/runtime/test-arith.scm
+++ b/tests/runtime/test-arith.scm
@@ -192,6 +192,7 @@ USA.
 
 (define-enumerated-test 'logsumexp-values
   (vector
+   (vector (iota 1000) 999.45867514538713)
    (vector '(999 1000) 1000.3132616875182)
    (vector '(-1000 -1000) (+ -1000 (log 2)))
    (vector '(0 0) (log 2)))