~ chicken-core (chicken-5) 67b5182b61f7bef54e3dac5d7ab47f6a65780eb8

commit 67b5182b61f7bef54e3dac5d7ab47f6a65780eb8
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jan 30 14:18:36 2016 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sat Jan 30 14:18:36 2016 +0100

    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.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index 082548d7..ab786be9 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 7318b937..8bab86c3 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 in 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 ab57a30a..63c7fc75 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 de31b1ac..472ade0f 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))))