Re: Segmentation fault

[Neil Jerram]

"frank schwidom" <address@hidden> writes:

> -------- Original-Nachricht --------
> Datum: Wed, 10 Oct 2007 18:27:42 +0200
> Von: "frank schwidom" <address@hidden>
> An: address@hidden
> Betreff: Segmentation fault
>
> Hi
>
> the following code leads to an segmentation fault in guile-1.6 and guile-1.8, 
> when executed with --debug
>
> currently the shortest Variant:
> ----------------
> (let ((f (lambda (g) (delay (g)))))
>   (force (f error)))
> ----------------

I believe the patch below is the correct fix for this.  Please test
and/or comment!

Regards,
        Neil

Index: libguile/ChangeLog
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/ChangeLog,v
retrieving revision 1.2412
diff -u -r1.2412 ChangeLog
--- libguile/ChangeLog  17 Oct 2007 21:56:09 -0000      1.2412
+++ libguile/ChangeLog  18 Oct 2007 23:26:19 -0000
@@ -1,3 +1,9 @@
+2007-10-19  Neil Jerram  <address@hidden>
+
+       * eval.c (unmemoize_delay): Extend the environment before
+       unmemoizing the promise thunk.  This fixes a segmentation fault
+       reported by Frank Schwidom.
+
 2007-10-17  Ludovic Courtès  <address@hidden>
 
        * read.c (CHAR_IS_BLANK_): Add `\r' (ASCII 0x0d).  This fixes a
Index: libguile/eval.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/eval.c,v
retrieving revision 1.418
diff -u -r1.418 eval.c
--- libguile/eval.c     29 Jul 2007 15:16:46 -0000      1.418
+++ libguile/eval.c     18 Oct 2007 23:26:23 -0000
@@ -1268,7 +1268,13 @@
 unmemoize_delay (const SCM expr, const SCM env)
 {
   const SCM thunk_expr = SCM_CADDR (expr);
-  return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, env));
+  /* A promise is implemented as a closure, and when applying a
+     closure the evaluator adds a new frame to the environment - even
+     though, in the case of a promise, the added frame is always
+     empty.  We need to extend the environment here in the same way,
+     so that any ILOCs in thunk_expr can be unmemoized correctly. */
+  const SCM new_env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+  return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, 
new_env));
 }
 
 
Index: test-suite/ChangeLog
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/ChangeLog,v
retrieving revision 1.407
diff -u -r1.407 ChangeLog
--- test-suite/ChangeLog        17 Oct 2007 21:56:10 -0000      1.407
+++ test-suite/ChangeLog        18 Oct 2007 23:26:32 -0000
@@ -1,3 +1,10 @@
+2007-10-19  Neil Jerram  <address@hidden>
+
+       * standalone/test-use-srfi: Use -q to avoid picking up the user's
+       ~/.guile file.
+
+       * tests/eval.test (promises)[unmemoizing a promise]: New test.
+
 2007-10-17  Ludovic Courtès  <address@hidden>
 
        * tests/reader.test (reading)[CR recognized as a token
Index: test-suite/standalone/test-use-srfi
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/standalone/test-use-srfi,v
retrieving revision 1.2
diff -u -r1.2 test-use-srfi
--- test-suite/standalone/test-use-srfi 15 Jan 2007 23:48:21 -0000      1.2
+++ test-suite/standalone/test-use-srfi 18 Oct 2007 23:26:32 -0000
@@ -19,14 +19,14 @@
 
 # Test that two srfi numbers on the command line work.
 #
-guile --use-srfi=1,10 >/dev/null <<EOF
+guile -q --use-srfi=1,10 >/dev/null <<EOF
 (if (and (defined? 'partition)
          (defined? 'define-reader-ctor))
     (exit 0)   ;; good
     (exit 1))  ;; bad
 EOF
 if test $? = 0; then :; else
-  echo "guile --user-srfi=1,10 fails to run"
+  echo "guile --use-srfi=1,10 fails to run"
   exit 1
 fi
 
@@ -38,7 +38,7 @@
 # `top-repl' the core bindings got ahead of anything --use-srfi gave.
 #
 
-guile --use-srfi=1 >/dev/null <<EOF
+guile -q --use-srfi=1 >/dev/null <<EOF
 (catch #t
   (lambda ()
     (iota 2 3 4))
@@ -47,7 +47,7 @@
 (exit 0)       ;; good
 EOF
 if test $? = 0; then :; else
-  echo "guile --user-srfi=1 doesn't give SRFI-1 iota"
+  echo "guile --use-srfi=1 doesn't give SRFI-1 iota"
   exit 1
 fi
 
@@ -56,12 +56,12 @@
 # exercises duplicates handling in `top-repl' versus `use-srfis' (in
 # boot-9.scm).
 #
-guile --use-srfi=17 >/dev/null <<EOF
+guile -q --use-srfi=17 >/dev/null <<EOF
 (if (procedure-with-setter? car)
     (exit 0)   ;; good
     (exit 1))  ;; bad
 EOF
 if test $? = 0; then :; else
-  echo "guile --user-srfi=17 doesn't give SRFI-17 car"
+  echo "guile --use-srfi=17 doesn't give SRFI-17 car"
   exit 1
 fi
Index: test-suite/tests/eval.test
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/tests/eval.test,v
retrieving revision 1.19
diff -u -r1.19 eval.test
--- test-suite/tests/eval.test  19 Jan 2007 08:53:33 -0000      1.19
+++ test-suite/tests/eval.test  18 Oct 2007 23:26:32 -0000
@@ -294,7 +294,26 @@
 
     (pass-if-exception "implicit forcing is not supported"
       exception:wrong-type-arg
-      (+ (delay (* 3 7)) 13))))
+      (+ (delay (* 3 7)) 13))
+
+    ;; Tests that require the debugging evaluator...
+    (let ((dopts (debug-options)))
+      (debug-enable 'debug)
+
+      (pass-if "unmemoizing a promise"
+        (display-backtrace
+        (let ((stack #f))
+          (false-if-exception (lazy-catch #t
+                                          (lambda ()
+                                            (let ((f (lambda (g) (delay (g)))))
+                                              (force (f error))))
+                                          (lambda _
+                                            (set! stack (make-stack #t)))))
+          stack)
+        (current-error-port))
+       #t)
+
+      (debug-options dopts))))
 
 ;;;
 ;;; letrec init evaluation