~ chicken-core (chicken-5) 026fdaa886d6c7e1c660b5cba4f858777d1d4ca3

commit 026fdaa886d6c7e1c660b5cba4f858777d1d4ca3
Author:     Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Mon Mar 17 21:30:39 2014 +0100
Commit:     Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Wed Mar 19 12:49:12 2014 +0100

    Don't fire finalizers on compiled, non-GCable constants (reported by "Pluijzer")
    
    Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>

diff --git a/NEWS b/NEWS
index e967a15b..c4302354 100644
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,11 @@
   - Fix subvector when the TO optional argument equals the given vector
     length (#1097)
 
+- Runtime system
+  - finalizers on constants are ignored in compiled code because compiled
+    constants are never GCed (before, the finalizer would be incorrectly
+    invoked after the first GC).  (Reported by "Pluijzer")
+
 - Build system
   - The tests can now be run without having to first install CHICKEN.
 
diff --git a/manual/Acknowledgements b/manual/Acknowledgements
index cbf9d5f3..14283c2f 100644
--- a/manual/Acknowledgements
+++ b/manual/Acknowledgements
@@ -35,25 +35,25 @@ Eric Merrit, Perry Metzger, Scott G. Miller, Mikael, Karel Miklav,
 Bruce Mitchener, Fadi Moukayed, Chris Moline, Eric E. Moore, Julian
 Morrison, Dan Muresan, David N. Murray, Timo Myyrä, "nicktick", Lars
 Nilsson, Ian Oversby, "o.t.", Gene Pavlovsky, Levi Pearson, Jeronimo
-Pellegrini, Nicolas Pelletier, Derrell Piper, Carlos Pita, Robin Lee
-Powell, Alan Post, "Pupeno", Davide Puricelli, "presto", Doug Quale,
-Imran Rafique, Eric Raible, Ivan Raikov, Santosh Rajan, Joel Reymont,
-"rivo", Chris Roberts, Eric Rochester, Paul Romanchenko, Andreas
-Rottman, David Rush, Lars Rustemeier, Daniel Sadilek, Otavio Salvador,
-Burton Samograd, "Sandro", "satori", Aleksej Saushev, Oskar Schirmer,
-Reed Sheridan, Ronald Schröder, Spencer Schumann, Ivan Shcheklein,
-Alex Shinn, Ivan Shmakov, "Shmul", Tony Sidaway, Jeffrey B. Siegal,
-Andrey Sidorenko, Michele Simionato, Iruata Souza, Volker Stolz, Jon
-Strait, Dorai Sitaram, Robert Skeels, Jason Songhurst, Clifford Stein,
-David Steiner, Sunnan, Zbigniew Szadkowski, Rick Taube, Nathan Thern,
-Mike Thomas, Minh Thu, Christian Tismer, Andre van Tonder, John Tobey,
-Henrik Tramberend, Vladimir Tsichevsky, James Ursetto, Neil van Dyke,
-Sam Varner, Taylor Venable, Sander Vesik, Jaques Vidrine, Panagiotis
-Vossos, Shawn Wagner, Peter Wang, Ed Watkeys, Brad Watson, Thomas
-Weidner, Göran Weinholt, Matthew Welland, Drake Wilson, Jörg
-Wittenberger, Peter Wright, Mark Wutka, Adam Young, Richard Zidlicky,
-Houman Zolfaghari and Florian Zumbiehl for bug-fixes, tips and
-suggestions.
+Pellegrini, Nicolas Pelletier, Derrell Piper, Carlos Pita, "Pluijzer",
+Robin Lee Powell, Alan Post, "Pupeno", Davide Puricelli, "presto",
+Doug Quale, Imran Rafique, Eric Raible, Ivan Raikov, Santosh Rajan,
+Joel Reymont, "rivo", Chris Roberts, Eric Rochester, Paul Romanchenko,
+Andreas Rottman, David Rush, Lars Rustemeier, Daniel Sadilek, Otavio
+Salvador, Burton Samograd, "Sandro", "satori", Aleksej Saushev, Oskar
+Schirmer, Reed Sheridan, Ronald Schröder, Spencer Schumann, Ivan
+Shcheklein, Alex Shinn, Ivan Shmakov, "Shmul", Tony Sidaway, Jeffrey
+B. Siegal, Andrey Sidorenko, Michele Simionato, Iruata Souza, Volker
+Stolz, Jon Strait, Dorai Sitaram, Robert Skeels, Jason Songhurst,
+Clifford Stein, David Steiner, Sunnan, Zbigniew Szadkowski, Rick
+Taube, Nathan Thern, Mike Thomas, Minh Thu, Christian Tismer, Andre
+van Tonder, John Tobey, Henrik Tramberend, Vladimir Tsichevsky, James
+Ursetto, Neil van Dyke, Sam Varner, Taylor Venable, Sander Vesik,
+Jaques Vidrine, Panagiotis Vossos, Shawn Wagner, Peter Wang, Ed
+Watkeys, Brad Watson, Thomas Weidner, Göran Weinholt, Matthew Welland,
+Drake Wilson, Jörg Wittenberger, Peter Wright, Mark Wutka, Adam Young,
+Richard Zidlicky, Houman Zolfaghari and Florian Zumbiehl for
+bug-fixes, tips and suggestions.
 
 Special thanks to Brandon van Every for contributing the (now defunct)
 [[http://www.cmake.org|CMake]] support and for helping with Windows
diff --git a/runtime.c b/runtime.c
index fdbc4d0b..35dcf2b6 100644
--- a/runtime.c
+++ b/runtime.c
@@ -497,6 +497,7 @@ static void C_fcall really_mark(C_word *x) C_regparm;
 static WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container) C_regparm;
 static C_ccall void values_continuation(C_word c, C_word closure, C_word dummy, ...) C_noret;
 static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);
+static C_regparm int C_fcall C_in_new_heapp(C_word x);
 static C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int ci) C_regparm;
 static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
 static double compute_symbol_table_load(double *avg_bucket_len, int *total);
@@ -2289,6 +2290,12 @@ C_regparm int C_fcall C_in_heapp(C_word x)
          (ptr >= tospace_start && ptr < tospace_limit);
 }
 
+/* Only used during major GC (heap realloc) */
+static C_regparm int C_fcall C_in_new_heapp(C_word x)
+{
+  C_byte *ptr = (C_byte *)(C_uword)x;
+  return (ptr >= new_tospace_start && ptr < new_tospace_limit);
+}
 
 C_regparm int C_fcall C_in_fromspacep(C_word x)
 {
@@ -3129,26 +3136,17 @@ C_regparm void C_fcall really_mark(C_word *x)
 
   val = *x;
 
-  p = (C_SCHEME_BLOCK *)val;
-  
-  /* not in stack and not in heap? */
-  if (
-#if C_STACK_GROWS_DOWNWARD
-       p < (C_SCHEME_BLOCK *)C_stack_pointer || p >= (C_SCHEME_BLOCK *)stack_bottom
-#else
-       p >= (C_SCHEME_BLOCK *)C_stack_pointer || p < (C_SCHEME_BLOCK *)stack_bottom
-#endif
-     )
-    if((p < (C_SCHEME_BLOCK *)fromspace_start || p >= (C_SCHEME_BLOCK *)C_fromspace_limit) &&
-       (p < (C_SCHEME_BLOCK *)tospace_start || p >= (C_SCHEME_BLOCK *)tospace_limit) ) {
+  if (!C_in_stackp(val) && !C_in_heapp(val)) {
 #ifdef C_GC_HOOKS
       if(C_gc_trace_hook != NULL) 
 	C_gc_trace_hook(x, gc_mode);
 #endif
 
       return;
-    }
+  }
 
+  p = (C_SCHEME_BLOCK *)val;
+  
   h = p->header;
 
   if(gc_mode == GC_MINOR) {
@@ -3473,27 +3471,17 @@ C_regparm void C_fcall really_remark(C_word *x)
 
   val = *x;
 
-  p = (C_SCHEME_BLOCK *)val;
-  
-  /* not in stack and not in heap? */
-  if(
-#if C_STACK_GROWS_DOWNWARD
-       p < (C_SCHEME_BLOCK *)C_stack_pointer || p >= (C_SCHEME_BLOCK *)stack_bottom
-#else
-       p >= (C_SCHEME_BLOCK *)C_stack_pointer || p < (C_SCHEME_BLOCK *)stack_bottom
-#endif
-    )
-    if((p < (C_SCHEME_BLOCK *)fromspace_start || p >= (C_SCHEME_BLOCK *)C_fromspace_limit) &&
-       (p < (C_SCHEME_BLOCK *)tospace_start || p >= (C_SCHEME_BLOCK *)tospace_limit) &&
-       (p < (C_SCHEME_BLOCK *)new_tospace_start || p >= (C_SCHEME_BLOCK *)new_tospace_limit) ) {
+  if (!C_in_stackp(val) && !C_in_heapp(val) && !C_in_new_heapp(val)) {
 #ifdef C_GC_HOOKS
       if(C_gc_trace_hook != NULL) 
 	C_gc_trace_hook(x, gc_mode);
 #endif
 
       return;
-    }
+  }
 
+  p = (C_SCHEME_BLOCK *)val;
+  
   h = p->header;
 
   if(is_fptr(h)) {
@@ -8282,7 +8270,8 @@ void C_ccall C_software_version(C_word c, C_word closure, C_word k)
 
 void C_ccall C_register_finalizer(C_word c, C_word closure, C_word k, C_word x, C_word proc)
 {
-  if(C_immediatep(x)) C_kontinue(k, x);
+  if(C_immediatep(x) || (!C_in_stackp(x) && !C_in_heapp(x))) /* not GCable? */
+    C_kontinue(k, x);
 
   C_do_register_finalizer(x, proc);
   C_kontinue(k, x);
diff --git a/tests/runtests.bat b/tests/runtests.bat
index a33d1b74..03e76849 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -432,6 +432,10 @@ rem if errorlevel 1 exit /b 1
 echo ======================================== finalizer tests ...
 %interpret% -s test-finalizers.scm
 if errorlevel 1 exit /b 1
+%compile% test-finalizers.scm
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
 
 echo ======================================== finalizer tests (2) ...
 %compile% finalizer-error-test.scm
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 6ea17308..8d98cc27 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -366,6 +366,8 @@ $compile symbolgc-tests.scm
 
 echo "======================================== finalizer tests ..."
 $interpret -s test-finalizers.scm
+$compile test-finalizers.scm
+./a.out
 $compile finalizer-error-test.scm
 echo "expect an error message here:"
 ./a.out -:hg101
diff --git a/tests/test-finalizers.scm b/tests/test-finalizers.scm
index 6ff33e1d..320a0976 100644
--- a/tests/test-finalizers.scm
+++ b/tests/test-finalizers.scm
@@ -1,5 +1,7 @@
 ;;;; test-finalizers.scm
 
+(use extras)
+
 (##sys#eval-debug-level 0)		; disable keeping trace-buffer with frameinfo
 
 (define x (list 1 2 3))
@@ -63,3 +65,16 @@ a fix that unfortunately disables finalizers in the interpreter
 (gc #t)
 (print n)
 (assert (= 2 n))
+
+;; Finalizers on constants are ignored in compiled mode (because
+;; they're never GCed).  Reported by "Pluijzer".
+
+(set! n 0)
+(define bar "constant string")
+(set-finalizer! bar bump)
+(set! bar #f)
+(gc #t)
+(print n)
+(cond-expand
+  (compiling (assert (= 0 n)))
+  (else (assert (= 1 n))))