From 72727d83c8c65a0ab42bd78a14cb8d5209545c9c Mon Sep 17 00:00:00 2001
From: Justin Koser <jmk@ccs.neu.edu>
Date: Sun, 2 Jul 2017 18:56:12 -0400
Subject: [PATCH] Don't panic about excessively large allocations (ticket #343)

---
 src/Lib/Common/ehandler.sch       | 12 ++++++++++++
 src/Lib/Common/errmsg.sch         |  2 ++
 src/Rts/IAssassin/millicode.c     |  6 ++++++
 src/Rts/Shared/i386-millicode.asm |  7 +++++--
 src/Rts/except.cfg                |  1 +
 5 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/src/Lib/Common/ehandler.sch b/src/Lib/Common/ehandler.sch
index 8aa318ff..5278d5e8 100644
--- a/src/Lib/Common/ehandler.sch
+++ b/src/Lib/Common/ehandler.sch
@@ -570,6 +570,18 @@
        ((= code $ex.put-char)
         (not-a-port "put-char" arg1))
 
+       ;; Allocation
+
+       ;; The allocation size is given in words, and it may be negative
+       ;; due to overflow when adding a vector header and/or aligning.
+       ;; We report the unsigned value in bytes.
+
+       ((= code $ex.alloc)
+        (let ((uwords (if (< arg1 0)
+                        (+ arg1 (expt 2 30))
+                        arg1)))
+          (error #f (errmsg 'msg:alloctoobig) (list (* uwords 4)))))
+
        ;; Others
 
        ;; For assertions, the first argument is the expression that
diff --git a/src/Lib/Common/errmsg.sch b/src/Lib/Common/errmsg.sch
index 21af0b85..94e6a826 100644
--- a/src/Lib/Common/errmsg.sch
+++ b/src/Lib/Common/errmsg.sch
@@ -228,4 +228,6 @@
 
 (msg:keyboardinterrupt          "keyboard interrupt")
 
+(msg:alloctoobig                "requested allocation exceeds max object size")
+
 ))
diff --git a/src/Rts/IAssassin/millicode.c b/src/Rts/IAssassin/millicode.c
index c9cdf4cf..1ec9f8c4 100644
--- a/src/Rts/IAssassin/millicode.c
+++ b/src/Rts/IAssassin/millicode.c
@@ -105,6 +105,9 @@ void EXPORT mc_alloc( word *globals )
   assert2( is_fixnum(globals[G_RESULT]) && (int)globals[G_RESULT] >= 0 );
 
   nwords = roundup_walign( nwords );
+  if ( nwords*sizeof(word) > LARGEST_OBJECT )
+    signal_exception( globals, EX_ALLOC, 0, 0 );
+
   p = GC_malloc( nwords*sizeof(word) );
   assert (p != 0);
   globals[ G_RESULT ] = (word)p;
@@ -119,6 +122,9 @@ void EXPORT mc_alloc( word *globals )
   assert2(((word)elim & 7) == 0);
 
   nwords = roundup_walign( nwords );
+  if ( nwords*sizeof(word) > LARGEST_OBJECT )
+    signal_exception( globals, EX_ALLOC, 0, 0 );
+
   p = etop;
   etop += nwords;
   if (etop <= elim) {
diff --git a/src/Rts/Shared/i386-millicode.asm b/src/Rts/Shared/i386-millicode.asm
index 3ef3dea6..136c67c6 100644
--- a/src/Rts/Shared/i386-millicode.asm
+++ b/src/Rts/Shared/i386-millicode.asm
@@ -213,13 +213,15 @@ EXTNAME(%1):
 	;; On entry, esp is off by 4
 PUBLIC i386_alloc_bv
 	MCg	mc_alloc_bv
+
 PUBLIC i386_alloc
 %ifdef OPTIMIZE_MILLICODE
 	mov	TEMP, [GLOBALS+G_ETOP]
 	add	RESULT, 7
 	and	RESULT, 0xfffffff8
-	add	TEMP, RESULT
 	add	TEMP, SCE_BUFFER
+	add	TEMP, RESULT		; Might wrap around on a large request
+	jc	L1
 	cmp	TEMP, CONT
 	ja	L1
 	mov	RESULT, [GLOBALS+G_ETOP]
@@ -242,8 +244,9 @@ PUBLIC i386_alloci
 	mov	ecx, RESULT		; Byte count for initialization
 	shr	ecx, 2			;   really want words
 	mov	TEMP, [GLOBALS+G_ETOP]
-	add	TEMP, RESULT
 	add	TEMP, SCE_BUFFER
+	add	TEMP, RESULT		; Might wrap around on a large request
+	jc	L2
 	cmp	TEMP, CONT
 	ja	L2
 	mov	RESULT, [GLOBALS+G_ETOP]
diff --git a/src/Rts/except.cfg b/src/Rts/except.cfg
index c40eb674..c16ecb9a 100644
--- a/src/Rts/except.cfg
+++ b/src/Rts/except.cfg
@@ -186,5 +186,6 @@
 (define-const breakpoint 202 "EX_BREAKPOINT" "EX_BREAKPOINT" "$ex.breakpoint")
 (define-const signal 203 "EX_SIGNAL" "EX_SIGNAL" "$ex.signal")
 (define-const timer 204 "EX_TIMER" "EX_TIMER" "$ex.timer")
+(define-const alloc 205 "EX_ALLOC" "EX_ALLOC" "$ex.alloc")
 
 ; eof