[Chicken-hackers] [PATCH] "deep-stack" option, declaration and build-mode

[Felix]

This patch adds a compiler option to emit extra nursery checks.

The "-deep-stack" compiler option or "(deep-stack)" declaration will
enable additional nursery-checks in compiled code to prevent
stack-overflows in deeply non-tail-recursive code. These checks are
normally omitted for performance reasons (measuring this turns out to
be difficult: the overhead for using a continuation procedure in the
first place appears to prevent the extra check to be noticed, but for
certain code patterns may still be noticable).  Interpreted code will
benefit from this feature, when the evaluator is compiled with the
"-deep-stack" option. This can be accomplished with a new build
option, "DEEPSTACK" (see the README for details).

Enabling this mode by default should IMHO be avoided, since runaway
recursions (which is the usual reason for stack-exhaustion) will
consume all available memory and thus may bring the machine to a halt.

Using DEEPSTACK mode will make the evaluator handle deeply recursive
code like the example given in #876.


cheers,
felix

>From 096baf1a78e0768ba6caf18fa98481205b8012e6 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Wed, 1 Aug 2012 13:54:47 +0200
Subject: [PATCH] Add compiler option to emit extra nursery checks.

The "-deep-stack" compiler option or "(deep-stack)" declaration will
enable additional nursery-checks in compiled code to prevent
stack-overflows in deeply non-tail-recursive code. These checks are
normally omitted for performance reasons (measuring this turns out to
be difficult: the overhead for using a continuation procedure in the
first place appears the extra check to be noticed, but for certain
code patterns may still be noticable).  Interpreted code will benefit
from this feature, when the evaluator is compiled with the
"-deep-stack" option. This can be accomplished with a new build option,
"DEEPSTACK" (see the README for details).
---
 Makefile.mingw            |    5 +++++
 README                    |   11 +++++++++++
 batch-driver.scm          |    2 ++
 c-backend.scm             |   22 +++++++++++++++-------
 c-platform.scm            |    5 +++--
 compiler-namespace.scm    |    1 +
 compiler.scm              |    2 ++
 csc.scm                   |    3 ++-
 defaults.make             |    8 ++++++++
 library.scm               |    1 +
 manual/Declarations       |   13 +++++++++++--
 manual/Using the compiler |    2 ++
 runtime.c                 |    7 +++++--
 support.scm               |    1 +
 14 files changed, 69 insertions(+), 14 deletions(-)

diff --git a/Makefile.mingw b/Makefile.mingw
index cf76ff4..43bb4c4 100644
--- a/Makefile.mingw
+++ b/Makefile.mingw
@@ -253,6 +253,11 @@ endif
        echo #ifndef C_CHICKEN_STATUS_PROGRAM >>$@
        echo # define C_CHICKEN_STATUS_PROGRAM "$(CHICKEN_STATUS_PROGRAM)" >>$@
        echo #endif >>$@
+ifdef DEEPSTACK
+       echo #ifndef C_DEEP_STACK >>$@
+       echo # define C_DEEP_STACK >>$@
+       echo #endif >>$@
+endif
        echo #ifndef C_BINARY_VERSION >>$@
        echo # define C_BINARY_VERSION $(BINARYVERSION) >>$@
        echo #endif >>$@
diff --git a/README b/README
index 2ea9f90..aa059f4 100644
--- a/README
+++ b/README
@@ -156,6 +156,17 @@
           option you can still enable symbol GC at runtime by passing 
           the `-:w' runtime option when running the program.
 
+       DEEPSTACK=1
+         Increase the frequency of checks for nursery-exhaustion. 
+         This will allow arbitrarily deep recursions unless code
+         is compiled with high optimization options. Note that you
+         can enable this for specific programs by using the 
+         `-deep-stack' compiler option. Enabling the DEEPSTACK build-
+          option will compile the runtime system and the core tools in
+         this mode and so applies to interpreted code as well. Runaway
+         recursion will not be caught and may consume all available
+         memory.
+
        EXTRA_CHICKEN_OPTIONS=...
          Additional options that should be passed to `chicken' when
          building the system.
diff --git a/batch-driver.scm b/batch-driver.scm
index bad5052..6f02a4d 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -227,6 +227,8 @@
     (when (memq 'optimize-leaf-routines options) (set! optimize-leaf-routines 
#t))
     (when (memq 'unsafe options) 
       (set! unsafe #t) )
+    (when (memq 'deep-stack options)
+      (set! enable-full-nursery-checks #t))
     (when (memq 'setup-mode options)
       (set! ##sys#setup-mode #t))
     (when (memq 'disable-interrupts options) (set! insert-timer-checks #f))
diff --git a/c-backend.scm b/c-backend.scm
index a7b6afe..042767b 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -642,7 +642,10 @@
                      (let ([al (make-argument-list argc "t")])
                        (apply gen (intersperse al #\,)) )
                      (gen ");}") ]
-                    [(or rest (> (lambda-literal-allocated ll) 0) 
(lambda-literal-external ll))
+                    [(or enable-full-nursery-checks
+                         rest
+                         (> (lambda-literal-allocated ll) 0)
+                         (lambda-literal-external ll))
                      (if (and rest (not (eq? rest-mode 'none)))
                          (set! nsr (lset-adjoin = nsr argc)) 
                          (set! ns (lset-adjoin = ns argc)) ) ] ) ) ) )
@@ -862,14 +865,19 @@
                    (if (eq? rest-mode 'none)
                        (when (> n 2) (gen #t "if(c<" n ") C_bad_min_argc_2(c," 
n ",t0);"))
                        (gen #t "if(c!=" n ") C_bad_argc_2(c," n ",t0);") ) )
-                 (when (and (not direct) (or external (> demand 0)))
-                   (when insert-timer-checks (gen #t "C_check_for_interrupt;"))
-                   (if (and looping (> demand 0))
-                       (gen #t "if(!C_stack_probe(a)){")
-                       (gen #t "if(!C_stack_probe(&a)){") ) ) ] )
+                 (unless direct
+                   (when (or enable-full-nursery-checks 
+                             (and (or external (> demand 0))))
+                     (when insert-timer-checks (gen #t 
"C_check_for_interrupt;"))
+                     (if (and looping (> demand 0))
+                         (gen #t "if(!C_stack_probe(a)){")
+                         (gen #t "if(!C_stack_probe(&a)){") ) ) ) ] )
           (when (and (not (eq? 'toplevel id))
                      (not direct)
-                     (or rest external (> demand 0)) )
+                     (or enable-full-nursery-checks
+                         rest
+                         external
+                         (> demand 0)) )
             (cond [rest
                    (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") 
"((void*)tr" n #\r)
                    (gen ",(void*)" id "r")
diff --git a/c-platform.scm b/c-platform.scm
index d502dc0..35957e7 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -48,7 +48,8 @@
      ##sys#list ##sys#cons ##sys#append ##sys#vector 
##sys#foreign-char-argument ##sys#foreign-fixnum-argument
      ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string 
##sys#peek-nonnull-c-string 
      ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string
-     ##sys#foreign-block-argument ##sys#foreign-string-argument 
##sys#foreign-pointer-argument ##sys#foreign-integer-argument
+     ##sys#foreign-block-argument ##sys#foreign-string-argument 
##sys#foreign-pointer-argument
+     ##sys#foreign-integer-argument
      ##sys#call-with-current-continuation) ) )
 
 (define default-debugging-declarations
@@ -91,7 +92,7 @@
     no-procedure-checks-for-toplevel-bindings module
     no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
     no-parentheses-synonyms no-symbol-escape r5rs-syntax 
emit-all-import-libraries
-    strict-types clustering
+    strict-types clustering deep-stack
     lambda-lift unboxing               ; OBSOLETE
     setup-mode no-module-registration) )
 
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index edc9bb4..bde25f2 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -111,6 +111,7 @@
  emit-syntax-trace-info
  emit-trace-info
  emit-type-file
+ enable-full-nursery-checks
  enable-inline-files
  enable-specialization
  encode-literal
diff --git a/compiler.scm b/compiler.scm
index 68061e0..25c6bd5 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -335,6 +335,7 @@
 (define bootstrap-mode #f)
 (define strict-variable-types #f)
 (define enable-specialization #f)
+(define enable-full-nursery-checks #f)
 
 ;;; Other global variables:
 
@@ -1381,6 +1382,7 @@
        ((block) (set! block-compilation #t))
        ((separate) (set! block-compilation #f))
        ((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
+       ((deep-stack) (set! enable-full-nursery-checks #t))
        ((unused)
        (for-each (cut mark-variable <> '##compiler#unused) (globalize-all (cdr 
spec))))
        ((enforce-argument-types)
diff --git a/csc.scm b/csc.scm
index 7aca745..99c1d21 100644
--- a/csc.scm
+++ b/csc.scm
@@ -142,7 +142,7 @@
     -no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
     -emit-all-import-libraries -setup-mode -no-elevation 
-no-module-registration
     -no-procedure-checks-for-usual-bindings -module
-    -specialize -strict-types -clustering
+    -specialize -strict-types -clustering -deep-stack
     -lambda-lift -unboxing             ; OBSOLETE
     -no-procedure-checks-for-toplevel-bindings))
 
@@ -403,6 +403,7 @@ Usage: #{csc} FILENAME | OPTION ...
     -strict-types                  assume variable do not change their type
     -clustering                    combine groups of local procedures into 
dispatch
                                      loop
+    -deep-stack                    allow deep non-tail recursions
 
   Configuration options:
 
diff --git a/defaults.make b/defaults.make
index a16e5a5..da65420 100644
--- a/defaults.make
+++ b/defaults.make
@@ -270,6 +270,9 @@ CHICKEN_OPTIONS += -feature debugbuild -verbose
 else
 CHICKEN_OPTIONS += -no-warnings
 endif
+ifdef DEEPSTACK
+CHICKEN_OPTIONS += -deep-stack
+endif
 ifndef BUILDING_CHICKEN_BOOT
 CHICKEN_OPTIONS += -specialize -types $(SRCDIR)types.db 
 endif
@@ -476,6 +479,11 @@ else
        echo "# define C_WINDOWS_SHELL 0" >>$@
 endif
        echo "#endif" >>$@
+ifdef DEEPSTACK
+       echo "#ifndef C_DEEP_STACK" >>$@
+       echo "# define C_DEEP_STACK" >>$@
+       echo "#endif" >>$@
+endif
        echo "#ifndef C_BINARY_VERSION" >>$@
        echo "# define C_BINARY_VERSION $(BINARYVERSION)" >>$@
        echo "#endif" >>$@
diff --git a/library.scm b/library.scm
index 67f859f..26ade37 100644
--- a/library.scm
+++ b/library.scm
@@ -3633,6 +3633,7 @@ EOF
                   (if (##sys#fudge 24) " dload" "") 
                   (if (##sys#fudge 28) " ptables" "")
                   (if (##sys#fudge 32) " gchooks" "") 
+                  (if (##sys#fudge 35) " deepstack" "") 
                   (if (##sys#fudge 39) " cross" "") ) ) )
        (string-append
         "Version " ##sys#build-version
diff --git a/manual/Declarations b/manual/Declarations
index 92b75f9..7a8a414 100644
--- a/manual/Declarations
+++ b/manual/Declarations
@@ -68,12 +68,21 @@ Declares that the given identifiers are always bound to 
procedure values.
 Enables or disables syntax-checking of embedded C/C++ code fragments. Checking 
C syntax is the default.
 
 
+=== deep-stack
+
+ [declaration specifier] (deep-stack)
+
+Emit extra nursery-checks in compiled code to prevent stack-overflows in deeply
+non-tail-recursive procedures. Equivalent to using the {{-deep-stack}} compiler
+option.
+
+
 === enforce-argument-types
 
- [declaration-specifier] (enforce-argument-types IDENTIFIER ...)
+ [declaration specifier] (enforce-argument-types IDENTIFIER ...)
 
 Declares that the toplevel procedures listed check the type of their arguments
-(either explicitly or by calling other enforcing procedures) and so a 
successfull
+(either explicitly or by calling other enforcing procedures) and so a 
successful
 invocation will indicate the arguments are of the types declared.
 
 
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 568a262..39f07d7 100644
--- a/manual/Using the compiler 
+++ b/manual/Using the compiler 
@@ -42,6 +42,8 @@ the source text should be read from standard input.
      -debug-level 1             is equivalent to -no-trace
      -debug-level 2             is equivalent to -scrutinize
 
+; -deep-stack : Emit extra code to check for nursery-exhaustion. This will 
avoid stack-overflows and allow arbitrarily deep non-tail recursions. Note that 
tight non-tail-recursive procedures which only invoke primitives and thus are 
subject to heavy optimizations may still cause stack overflow.
+
 ; -disable-interrupts : Equivalent to the {{(disable-interrupts)}} 
declaration. No interrupt-checks are generated for compiled programs.
 
 ; -disable-stack-overflow-checks : Disables detection of stack overflows. This 
is equivalent to running the compiled executable with the {{-:o}} runtime 
option.
diff --git a/runtime.c b/runtime.c
index dd1c837..ec48147 100644
--- a/runtime.c
+++ b/runtime.c
@@ -4176,9 +4176,12 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
     return C_fix(126);
 #endif
 
-  case C_fix(35):              /* unused */
-    /* used to be apply-hook indicator */
+  case C_fix(35):              /* build with DEEPSTACK? */
+#ifdef C_DEEP_STACK
+    return C_SCHEME_TRUE;
+#else
     return C_SCHEME_FALSE;
+#endif
     
   case C_fix(36):              /* toggle debug mode */
     debug_mode = !debug_mode;
diff --git a/support.scm b/support.scm
index 0ed4839..27f5ba7 100644
--- a/support.scm
+++ b/support.scm
@@ -1711,6 +1711,7 @@ Usage: chicken FILENAME OPTION ...
     -strict-types                assume variable do not change their type
     -clustering                  combine groups of local procedures into 
dispatch
                                    loop
+    -deep-stack                  allow deep non-tail recursions
 
   Configuration options:
 
-- 
1.7.0.4