From af233a2ac2d4c42695db7c4734c5fabb7d00b13c Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Thu, 30 Jul 2009 14:19:46 +0300
Subject: [PATCH] added post-gc-hooks, a list of thunks that are invoked after
 garbage collection.

---
 scheme/ikarus.collect.ss | 41 +++++++++++++++++++++++++++++++---------
 scheme/last-revision     |  2 +-
 scheme/makefile.ss       |  1 +
 src/ikarus-collect.c     | 11 +++++++++++
 4 files changed, 45 insertions(+), 10 deletions(-)

diff --git a/scheme/ikarus.collect.ss b/scheme/ikarus.collect.ss
index bbe46c6..d86ddd5 100644
--- a/scheme/ikarus.collect.ss
+++ b/scheme/ikarus.collect.ss
@@ -16,26 +16,49 @@
 
 (library (ikarus collect)
   (export do-overflow do-overflow-words do-vararg-overflow collect
-          do-stack-overflow collect-key)
+          do-stack-overflow collect-key post-gc-hooks)
   (import 
-    (except (ikarus) collect collect-key)
+    (except (ikarus) collect collect-key post-gc-hooks)
     (ikarus system $fx)
     (ikarus system $arg-list))
 
+ 
+(define post-gc-hooks 
+  (make-parameter '()
+    (lambda (ls)
+      ;;; null? check so that we don't reference list? and andmap
+      ;;; at this stage of booting.
+      (if (or (null? ls) (and (list? ls) (andmap procedure? ls)))
+          ls
+          (die 'post-gc-hooks "not a list of procedures" ls)))))
+
+(define (do-post-gc ls n)
+  (let ([k0 (collect-key)])
+    (parameterize ([post-gc-hooks '()])
+      (for-each (lambda (x) (x)) ls))
+    (if (eq? k0 (collect-key)) 
+        (let ([was-enough? (foreign-call "ik_collect_check" n)])
+          ;;; handlers ran without GC but there is was not enough 
+          ;;; space in the nursery for the pending allocation, 
+          (unless was-enough? (do-post-gc ls n)))
+        (let ()
+          ;;; handlers did cause a GC, so, do the handlers again.
+          (do-post-gc ls n)))))
+
 (define do-overflow
   (lambda (n)
     (foreign-call "ik_collect" n)
-    (void)))
+    (let ([ls (post-gc-hooks)])
+      (unless (null? ls) (do-post-gc ls n)))))
 
 (define do-overflow-words
   (lambda (n)
-    (foreign-call "ik_collect" ($fxsll n 2))
-    (void)))
+    (let ([n ($fxsll n 2)])
+      (foreign-call "ik_collect" n)
+      (let ([ls (post-gc-hooks)])
+        (unless (null? ls) (do-post-gc ls n))))))
 
-(define do-vararg-overflow
-  (lambda (n)
-    (foreign-call "ik_collect_vararg" n)
-    (void)))
+(define do-vararg-overflow do-overflow)
 
 (define collect
   (lambda ()
diff --git a/scheme/last-revision b/scheme/last-revision
index dec2115..aae736a 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1831
+1832
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 1945c62..8228aed 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -610,6 +610,7 @@
     [do-vararg-overflow                          ]
     [collect                                     i]
     [collect-key                                 i]
+    [post-gc-hooks                               i]
     [do-stack-overflow                           ]
     [make-promise                                ]
     [make-traced-procedure                       i]
diff --git a/src/ikarus-collect.c b/src/ikarus-collect.c
index 4a1728e..0dbf77a 100644
--- a/src/ikarus-collect.c
+++ b/src/ikarus-collect.c
@@ -350,6 +350,7 @@ static void gc_add_tconcs(gc_t*);
  */
 
 
+
 ikpcb* ik_collect_vararg(int req, ikpcb* pcb){
   return ik_collect(req, pcb);
 }
@@ -372,6 +373,16 @@ static void fix_new_pages(gc_t* gc);
 
 extern void verify_integrity(ikpcb* pcb, char*);
 
+ikptr ik_collect_check(unsigned long int req, ikpcb* pcb){
+  long int bytes = ((long int)pcb->allocation_redline) -
+                   ((long int)pcb->allocation_pointer);
+  if (bytes >= req) {
+    return true_object;
+  } else {
+    ik_collect(req, pcb);
+    return false_object;
+  }
+}
 
 ikpcb* 
 ik_collect(unsigned long int mem_req, ikpcb* pcb){