From 2d388754f92f8572dccccd50d276f50abca6e402 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              |   60 ++++++++++++++++++++++++++++++++++++----------
 tests/compiler-tests.scm |   10 ++++++++
 4 files changed, 68 insertions(+), 17 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..1505de4 100644
--- a/support.scm
+++ b/support.scm
@@ -1462,19 +1462,53 @@
 (define (constant-form-eval op argnodes k)  ; Used only in optimizer.scm
   (let* ((args (map (lambda (n) (first (node-parameters n))) argnodes))
 	 (form (cons op (map (lambda (arg) `(quote ,arg)) args))))
-    (handle-exceptions ex 
-	(begin
-	  (k #f form #f (get-condition-property ex 'exn 'message)))
-      ;; op must have toplevel binding, result must be single-valued
-      (let ((proc (##sys#slot op 0)))
-	(if (procedure? proc)
-	    (let ((results (receive (apply proc args))))
-	      (cond ((= 1 (length 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))))))
+    ;; op must have toplevel binding, result must be single-valued
+    (let ((proc (##sys#slot op 0)))
+      (if (procedure? proc)
+	  (let ((results (handle-exceptions ex
+			     (k #f form #f
+				(get-condition-property ex 'exn 'message))
+			   (receive (apply proc args)))))
+	    (cond ((node? results) ; TODO: This should not happen
+		   (k #f form #f #f))
+		  ((and (= 1 (length results))
+			(encodeable-literal? (car results)))
+		   (debugging 'o "folded constant expression" form)
+		   (k #t form (car results) #f))
+		  ((= 1 (length results)) ; not encodeable; don't fold
+		   (k #f form #f #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).  If the string is too large to allocate,
+	 ;; we'll also get an exception!
+	 (let ((str (handle-exceptions ex #f (number->string lit 16))))
+	   (and str (fits? (string-length str)))))
+	((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..472ade0 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -241,6 +241,16 @@
                       (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* ((bignum (expt 2 70000000))
+       ;; This prevents complete evaluation at compile-time
+       (unknown-bignum ((foreign-lambda* scheme-object
+			    ((scheme-object n)) "C_return(n);") bignum)))
+  (assert (equal? 70000001 (integer-length unknown-bignum))))
+
+
 ;; 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))))
-- 
1.7.10.4