[commit: ghc] master: Check for integer overflow in allocate() (#9172) (db64180)

git at git.haskell.org git at git.haskell.org
Tue Jul 1 14:20:42 UTC 2014


Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/db64180896b395283f443d66a308048c605b217d/ghc

>---------------------------------------------------------------

commit db64180896b395283f443d66a308048c605b217d
Author: Reid Barton <rwbarton at gmail.com>
Date:   Tue Jul 1 10:20:31 2014 -0400

    Check for integer overflow in allocate() (#9172)
    
    Summary: Check for integer overflow in allocate() (#9172)
    
    Test Plan: validate
    
    Reviewers: austin
    
    Reviewed By: austin
    
    Subscribers: simonmar, relrod, carter
    
    Differential Revision: https://phabricator.haskell.org/D36


>---------------------------------------------------------------

db64180896b395283f443d66a308048c605b217d
 rts/sm/Storage.c                     | 10 +++++++++-
 testsuite/.gitignore                 |  3 +++
 testsuite/tests/rts/all.T            |  5 +++++
 testsuite/tests/rts/overflow1.hs     | 11 +++++++++++
 testsuite/tests/rts/overflow1.stderr |  1 +
 testsuite/tests/rts/overflow2.hs     | 20 ++++++++++++++++++++
 testsuite/tests/rts/overflow2.stderr |  1 +
 testsuite/tests/rts/overflow3.hs     | 20 ++++++++++++++++++++
 testsuite/tests/rts/overflow3.stderr |  1 +
 9 files changed, 71 insertions(+), 1 deletion(-)

diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c
index 86bd1c2..d002fec 100644
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -686,7 +686,15 @@ StgPtr allocate (Capability *cap, W_ n)
     CCS_ALLOC(cap->r.rCCCS,n);
     
     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
-        W_ req_blocks =  (W_)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
+        // The largest number of bytes such that
+        // the computation of req_blocks will not overflow.
+        W_ max_bytes = (HS_WORD_MAX & ~(BLOCK_SIZE-1)) / sizeof(W_);
+        W_ req_blocks;
+
+        if (n > max_bytes)
+            req_blocks = HS_WORD_MAX; // signal overflow below
+        else
+            req_blocks = (W_)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 
         // Attempting to allocate an object larger than maxHeapSize
         // should definitely be disallowed.  (bug #1791)
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index f28edef..376318d 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1293,6 +1293,9 @@ mk/ghcconfig_*_inplace_bin_ghc-stage2.exe.mk
 /tests/rts/linker_unload
 /tests/rts/outofmem
 /tests/rts/outofmem2
+/tests/rts/overflow1
+/tests/rts/overflow2
+/tests/rts/overflow3
 /tests/rts/prep.out
 /tests/rts/return_mem_to_os
 /tests/rts/rtsflags001
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index a56a3f3..d7c74c5 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -230,3 +230,8 @@ test('T9045', [ omit_ways(['ghci']), extra_run_opts('10000 +RTS -A8k -RTS') ], c
 # I couldn't reproduce 9078 with the -threaded runtime, but could easily
 # with the non-threaded one.
 test('T9078', [ omit_ways(threaded_ways) ], compile_and_run, ['-with-rtsopts="-DS" -debug'])
+
+# 251 = RTS exit code for "out of memory"
+test('overflow1', [ exit_code(251) ], compile_and_run, [''])
+test('overflow2', [ exit_code(251) ], compile_and_run, [''])
+test('overflow3', [ exit_code(251) ], compile_and_run, [''])
diff --git a/testsuite/tests/rts/overflow1.hs b/testsuite/tests/rts/overflow1.hs
new file mode 100644
index 0000000..63ed5a4
--- /dev/null
+++ b/testsuite/tests/rts/overflow1.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import Data.Array.IO
+import Data.Word
+
+-- Try to overflow BLOCK_ROUND_UP in the computation of req_blocks in allocate()
+-- Here we invoke allocate() via newByteArray# and the array package.
+-- Request a number of bytes close to HS_WORD_MAX,
+-- subtracting a few words for overhead in newByteArray#.
+-- Allocate Word32s (rather than Word8s) to get around bounds-checking in array.
+main = newArray (0,maxBound `div` 4 - 10) 0 :: IO (IOUArray Word Word32)
diff --git a/testsuite/tests/rts/overflow1.stderr b/testsuite/tests/rts/overflow1.stderr
new file mode 100644
index 0000000..734ca95
--- /dev/null
+++ b/testsuite/tests/rts/overflow1.stderr
@@ -0,0 +1 @@
+overflow1: out of memory
diff --git a/testsuite/tests/rts/overflow2.hs b/testsuite/tests/rts/overflow2.hs
new file mode 100644
index 0000000..ac72158
--- /dev/null
+++ b/testsuite/tests/rts/overflow2.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Main where
+
+import Foreign
+
+-- Test allocate(), the easy way.
+data Cap = Cap
+foreign import ccall "rts_unsafeGetMyCapability" myCapability :: IO (Ptr Cap)
+foreign import ccall "allocate" allocate :: Ptr Cap -> Word -> IO (Ptr ())
+
+-- Number of words n such that n * sizeof(W_) exactly overflows a word
+-- (2^30 on a 32-bit system, 2^61 on a 64-bit system)
+overflowWordCount :: Word
+overflowWordCount = fromInteger $
+                    (fromIntegral (maxBound :: Word) + 1) `div`
+                    fromIntegral (sizeOf (undefined :: Word))
+
+main = do
+  cap <- myCapability
+  allocate cap (overflowWordCount - 1)
diff --git a/testsuite/tests/rts/overflow2.stderr b/testsuite/tests/rts/overflow2.stderr
new file mode 100644
index 0000000..be65509
--- /dev/null
+++ b/testsuite/tests/rts/overflow2.stderr
@@ -0,0 +1 @@
+overflow2: out of memory
diff --git a/testsuite/tests/rts/overflow3.hs b/testsuite/tests/rts/overflow3.hs
new file mode 100644
index 0000000..31dfd5d
--- /dev/null
+++ b/testsuite/tests/rts/overflow3.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Main where
+
+import Foreign
+
+-- Test allocate(), the easy way.
+data Cap = Cap
+foreign import ccall "rts_unsafeGetMyCapability" myCapability :: IO (Ptr Cap)
+foreign import ccall "allocate" allocate :: Ptr Cap -> Word -> IO (Ptr ())
+
+-- Number of words n such that n * sizeof(W_) exactly overflows a word
+-- (2^30 on a 32-bit system, 2^61 on a 64-bit system)
+overflowWordCount :: Word
+overflowWordCount = fromInteger $
+                    (fromIntegral (maxBound :: Word) + 1) `div`
+                    fromIntegral (sizeOf (undefined :: Word))
+
+main = do
+  cap <- myCapability
+  allocate cap (overflowWordCount + 1)
diff --git a/testsuite/tests/rts/overflow3.stderr b/testsuite/tests/rts/overflow3.stderr
new file mode 100644
index 0000000..6c804e5
--- /dev/null
+++ b/testsuite/tests/rts/overflow3.stderr
@@ -0,0 +1 @@
+overflow3: out of memory



More information about the ghc-commits mailing list