From 078db12b75a479e787013e28a54749aa9af27ecc Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sat, 30 Jan 2016 14:23:47 +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 +++++++++----
 compiler-namespace.scm |  1 +
 support.scm            | 55 ++++++++++++++++++++++++++++++++++++++------------
 4 files changed, 54 insertions(+), 17 deletions(-)

diff --git a/NEWS b/NEWS
index 401a192..777a6be 100644
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,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 c534bed..938ba47 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1364,10 +1364,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 (not (zero? (arithmetic-shift 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/compiler-namespace.scm b/compiler-namespace.scm
index 1df475f..408ad2c 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -115,6 +115,7 @@
  enable-inline-files
  enable-specialization
  encode-literal
+ encodeable-literal?
  eq-inline-operator
  estimate-foreign-result-location-size
  estimate-foreign-result-size
diff --git a/support.scm b/support.scm
index 28437ff..0a0f97a 100644
--- a/support.scm
+++ b/support.scm
@@ -1487,19 +1487,48 @@
 (define (constant-form-eval op argnodes k)
   (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)
+    (zero? (arithmetic-shift n -24)))
+  (cond ((immediate? lit))
+	((fixnum? lit))
+	((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:
-- 
2.1.4