Re: Segmentation fault

[Neil Jerram <neil@ossau.uklinux.net>]

ludovic.courtes@laas.fr (Ludovic Courtès) writes:

> Hi,
>
> Neil Jerram <neil@ossau.uklinux.net> writes:
>
>> I believe the patch below is the correct fix for this.  Please test
>> and/or comment!
>
> Works like a charm!

For 1.6 the fix is slightly different; please see below and let me
know if you have any comments.

To test this in 1.6, I've added all the "promises" tests from the HEAD
eval.test to the 1.6 eval.test.  All the tests pass for me, but is
there any risk that they might not pass on another platform, and so
introduce a regression in 1.6.x?

(I've committed the 1.6 fix and new tests for now, and will change them
if needed.)

Regards,
        Neil

Index: libguile/ChangeLog
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/ChangeLog,v
retrieving revision 1.1465.2.222
diff -u -r1.1465.2.222 ChangeLog
--- libguile/ChangeLog	4 Dec 2006 23:57:05 -0000	1.1465.2.222
+++ libguile/ChangeLog	20 Oct 2007 10:08:14 -0000
@@ -1,3 +1,9 @@
+2007-10-20  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* eval.c (unmemocopy): For SCM_IM_DELAY, extend the environment
+	before unmemoizing the promise thunk.  This fixes a segmentation
+	fault reported by Frank Schwidom.
+
 2006-12-05  Kevin Ryde  <user42@zip.com.au>
 
 	* numbers.c (scm_product): For flonum*inum and complex*inum, return
Index: libguile/eval.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/eval.c,v
retrieving revision 1.234.2.12
diff -u -r1.234.2.12 eval.c
--- libguile/eval.c	2 Oct 2006 20:22:49 -0000	1.234.2.12
+++ libguile/eval.c	20 Oct 2007 10:08:18 -0000
@@ -1438,6 +1439,13 @@
 	case (SCM_ISYMNUM (SCM_IM_DELAY)):
 	  ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
 	  x = SCM_CDR (x);
+	  /* 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. */
+	  env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
 	  goto loop;
 	case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
 	  ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
Index: test-suite/ChangeLog
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/ChangeLog,v
retrieving revision 1.88.2.96
diff -u -r1.88.2.96 ChangeLog
--- test-suite/ChangeLog	4 Oct 2006 22:21:56 -0000	1.88.2.96
+++ test-suite/ChangeLog	20 Oct 2007 10:08:24 -0000
@@ -1,3 +1,11 @@
+2007-10-19  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* tests/eval.test ("continuations"): Use with-debugging-evaluator.
+	("promises"): Add promise tests from CVS HEAD.
+
+	* lib.scm (with-debugging-evaluator*, with-debugging-evaluator):
+	New utilities.
+
 2006-10-05  Kevin Ryde  <user42@zip.com.au>
 
 	* tests/ftw.test: New file.
Index: test-suite/lib.scm
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/lib.scm,v
retrieving revision 1.17.4.4
diff -u -r1.17.4.4 lib.scm
--- test-suite/lib.scm	23 May 2005 20:15:35 -0000	1.17.4.4
+++ test-suite/lib.scm	20 Oct 2007 10:08:24 -0000
@@ -33,6 +33,9 @@
  ;; Naming groups of tests in a regular fashion.
  with-test-prefix with-test-prefix* current-test-prefix
 
+ ;; Using the debugging evaluator.
+ with-debugging-evaluator with-debugging-evaluator*
+
  ;; Reporting results in various ways.
  register-reporter unregister-reporter reporter-registered?
  make-count-reporter print-counts
@@ -352,6 +355,22 @@
 (defmacro with-test-prefix (prefix . body)
   `(with-test-prefix* ,prefix (lambda () ,@body)))
 
+;;; Call THUNK using the debugging evaluator.
+(define (with-debugging-evaluator* thunk)
+  (let ((dopts #f))
+    (dynamic-wind
+	(lambda ()
+	  (set! dopts (debug-options))
+	  (debug-enable 'debug))
+	thunk
+	(lambda ()
+	  (debug-options dopts)))))
+
+;;; Evaluate BODY... using the debugging evaluator.
+(define-macro (with-debugging-evaluator . body)
+  `(with-debugging-evaluator* (lambda () ,@body)))
+
+
 \f
 ;;;; REPORTERS
 ;;;;
cvs diff: Diffing test-suite/tests
Index: test-suite/tests/eval.test
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/tests/eval.test,v
retrieving revision 1.6.2.5
diff -u -r1.6.2.5 eval.test
--- test-suite/tests/eval.test	2 Oct 2006 20:12:44 -0000	1.6.2.5
+++ test-suite/tests/eval.test	20 Oct 2007 10:08:24 -0000
@@ -209,8 +209,7 @@
 
   (with-test-prefix "stacks/debugging"
 
-    (let ((dopts (debug-options)))
-      (debug-enable 'debug)
+    (with-debugging-evaluator
 
       (pass-if "make-stack"
         (stack? (call-with-current-continuation make-stack)))
@@ -220,10 +219,91 @@
 	  (or (boolean? id) (symbol? id))))
 
       (pass-if "last-stack-frame"
-        (pair? (call-with-current-continuation last-stack-frame)))
-
-      (debug-options dopts))
+        (pair? (call-with-current-continuation last-stack-frame))))
 
     ))
 
+;;;
+;;; promises
+;;;
+
+(with-test-prefix "promises"
+
+  (with-test-prefix "basic promise behaviour"
+
+    (pass-if "delay gives a promise"
+      (promise? (delay 1)))
+
+    (pass-if "force evaluates a promise"
+      (eqv? (force (delay (+ 1 2))) 3))
+
+    (pass-if "a forced promise is a promise"
+      (let ((p (delay (+ 1 2))))
+	(force p)
+	(promise? p)))
+
+    (pass-if "forcing a forced promise works"
+      (let ((p (delay (+ 1 2))))
+	(force p)
+	(eqv? (force p) 3)))
+
+    (pass-if "a promise is evaluated once"
+      (let* ((x 1)
+	     (p (delay (+ x 1))))
+	(force p)
+	(set! x (+ x 1))
+	(eqv? (force p) 2)))
+
+    (pass-if "a promise may call itself"
+      (define p
+	(let ((x 0))
+	  (delay 
+	    (begin 
+	      (set! x (+ x 1))
+	      (if (> x 1) x (force p))))))
+      (eqv? (force p) 2))
+
+    (pass-if "a promise carries its environment"
+      (let* ((x 1) (p #f))
+	(let* ((x 2))
+	  (set! p (delay (+ x 1))))
+	(eqv? (force p) 3)))
+
+    (pass-if "a forced promise does not reference its environment"
+      (let* ((g (make-guardian))
+	     (p #f))
+	(let* ((x (cons #f #f)))
+	  (g x)
+	  (set! p (delay (car x))))
+	(force p)
+	(gc)
+	(if (not (equal? (g) (cons #f #f)))
+	    (throw 'unresolved)
+	    #t))))
+
+  (with-test-prefix "extended promise behaviour"
+
+    (pass-if-exception "forcing a non-promise object is not supported"
+      exception:wrong-type-arg
+      (force 1))
+
+    (pass-if-exception "implicit forcing is not supported"
+      exception:wrong-type-arg
+      (+ (delay (* 3 7)) 13))
+
+    ;; Tests that require the debugging evaluator...
+    (with-debugging-evaluator
+
+      (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)
+	 (%make-void-port "w"))
+	#t))))
 ;;; eval.test ends here



_______________________________________________
Bug-guile mailing list
Bug-guile@gnu.org
http://lists.gnu.org/mailman/listinfo/bug-guile