Release some of the memory allocated to a stack when it shrinks (#2090)

[ghc-hetmet.git] / rts / sm / BlockAlloc.c

diff --git a/rts/sm/BlockAlloc.c b/rts/sm/BlockAlloc.c
index 8b85956..2e8ad73 100644 (file)
--- a/rts/sm/BlockAlloc.c
+++ b/rts/sm/BlockAlloc.c
@@ -549,6 +549,40 @@ freeChain_lock(bdescr *bd)
     RELEASE_SM_LOCK;
 }
 
+bdescr *
+splitBlockGroup (bdescr *bd, nat blocks)
+{
+    bdescr *new_bd;
+
+    if (bd->blocks <= blocks) {
+        barf("splitLargeBlock: too small");
+    }
+
+    if (bd->blocks > BLOCKS_PER_MBLOCK) {
+        nat mblocks;
+        void *new_mblock;
+        if ((blocks - BLOCKS_PER_MBLOCK) % (MBLOCK_SIZE / BLOCK_SIZE) != 0) {
+            barf("splitLargeBlock: not a multiple of a megablock");
+        }
+        mblocks = 1 + (blocks - BLOCKS_PER_MBLOCK) / (MBLOCK_SIZE / BLOCK_SIZE);
+        new_mblock = (void *) ((P_)MBLOCK_ROUND_DOWN(bd) + mblocks * MBLOCK_SIZE_W);
+        initMBlock(new_mblock);
+        new_bd = FIRST_BDESCR(new_mblock);
+        new_bd->blocks = MBLOCK_GROUP_BLOCKS(mblocks);
+    }
+    else
+    {
+        // NB. we're not updating all the bdescrs in the split groups to
+        // point to the new heads, so this can only be used for large
+        // objects which do not start in the non-head block.
+        new_bd = bd + blocks;
+        new_bd->blocks = bd->blocks - blocks;
+    }
+    bd->blocks = blocks;
+
+    return new_bd;
+}
+
 static void
 initMBlock(void *mblock)
 {