From 3e7eaaa09631667ed3a07bac035b26798705d56e Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sat, 30 Jan 2016 14:18:36 +0100
Subject: [PATCH] Don't silently truncate huge literals.

Instead stop compilation and show an error.  Unfortunately, we can't
really show the object that caused it to bomb, because that would be too
large to print.

Don't constant-fold expressions that result in such an unencodeable
literal.
---
 NEWS                     |  1 +
 c-backend.scm            | 14 ++++++++++----
 support.scm              | 30 +++++++++++++++++++++++++++++-
 tests/compiler-tests.scm |  7 +++++++
 4 files changed, 47 insertions(+), 5 deletions(-)

diff --git a/NEWS b/NEWS
index 082548d..ab786be 100644
--- a/NEWS
+++ b/NEWS
@@ -55,6 +55,7 @@
   - Compiler rewrites for char{<,>,<=,>=,=}? are now safe (#1122).
   - When requesting to emit import libraries that don't exist, the
      compiler now gives an error instead of quietly continuing (#1188).
+  - Don't silently truncate huge literals (thanks to Claude Marinier).
 
 - Core libraries
    - SRFI-18: thread-join! no longer gives an error when passed a
diff --git a/c-backend.scm b/c-backend.scm
index 7318b93..f16237a 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1394,10 +1394,16 @@ return((C_header_bits(lit) >> 24) & 0xff);
     (foreign-lambda* int ((scheme-object lit))
       "return(C_header_size(lit));"))
   (define (encode-size n)
-    ;; only handles sizes in the 24-bit range!
-    (string (integer->char (bitwise-and #xff (arithmetic-shift n -16)))
-	    (integer->char (bitwise-and #xff (arithmetic-shift n -8)))
-	    (integer->char (bitwise-and #xff n))))
+    (if (fx> (fxlen n) 24)
+	;; Unfortunately we can't do much more to help the user.
+	;; Printing the literal is not helpful because it's *huge*,
+	;; and we have no line number information here.
+	(quit-compiling
+	 "Encoded literal size of ~S is too large (must fit 24 bits)" n)
+	(string
+	 (integer->char (bitwise-and #xff (arithmetic-shift n -16)))
+	 (integer->char (bitwise-and #xff (arithmetic-shift n -8)))
+	 (integer->char (bitwise-and #xff n)))))
   (define (finish str)		   ; can be taken out at a later stage
     (string-append (string #\xfe) str))
   (finish
diff --git a/support.scm b/support.scm
index ab57a30..523ea48 100644
--- a/support.scm
+++ b/support.scm
@@ -1469,13 +1469,41 @@
       (let ((proc (##sys#slot op 0)))
 	(if (procedure? proc)
 	    (let ((results (receive (apply proc args))))
-	      (cond ((= 1 (length results))
+	      (cond ((and (= 1 (length results))
+			  (encodeable-literal? (car results)))
 		     (debugging 'o "folded constant expression" form)
 		     (k #t form (car results) #f))
 		    (else 
 		     (bomb "attempt to constant-fold call to procedure that has multiple results" form))))
 	    (bomb "attempt to constant-fold call to non-procedure" form))))))
 
+;; Is the literal small enough to be encoded?  Otherwise, it should
+;; not be constant-folded.
+(define (encodeable-literal? lit)
+  (define getsize
+    (foreign-lambda* int ((scheme-object lit))
+      "return(C_header_size(lit));"))
+  (define (fits? n)
+    (fx<= (integer-length n) 24))
+  (cond ((immediate? lit))
+	((exact-integer? lit)
+	 ;; Could use integer-length, but that's trickier (minus
+	 ;; symbol etc)
+	 (fits? (string-length (number->string lit 16))))
+	((flonum? lit))
+	((symbol? lit)
+	 (let ((str (##sys#slot lit 1)))
+	   (fits? (string-length str)) ) )
+	((##core#inline "C_byteblockp" lit)
+	 (fits? (getsize lit)) )
+	(else
+	 (let ((len (getsize lit)))
+	   (and (fits? len)
+		(every
+		 encodeable-literal?
+		 (list-tabulate len (lambda (i)
+				      (##sys#slot lit i))))) )) ) )
+
 
 ;;; Dump node structure:
 
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index de31b1a..7a42b29 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -241,6 +241,13 @@
                       (set! outer-bar inner-bar) 
                       (outer-bar '#f))))) 
 
+;; Found by Claude Marinier: Huge literals with a length which need
+;; more than 3 bytes to encode would get silently truncated.  We'll
+;; prevent constant-folding if it would lead to such large literals.
+(let ((big-prime-str (number->string (expt 2 74207281) 16)))
+  (assert (equal? 18551821 (string-length big-prime-str))))
+
+
 ;; Test that encode-literal/decode-literal use the proper functions
 ;; to decode number literals.
 (assert (equal? '(+inf.0 -inf.0) (list (fp/ 1.0 0.0) (fp/ -1.0 0.0))))
-- 
2.1.4