Re: [Gcl-devel] Segmentaton fault

[Camm Maguire]

Greetings!

OK, this is not quite yet ready for prime time, but in case anyone
would like to play with this, one can get rudimentary sibling call
optimization support under GCL.  The patch below is against 2.6.1 (not
applied).

Two items:

1) Graceful continuation in case of C stack overflow -- there appears
   to be a conflict between sigaltstack stack redirection and the
   pcl/clcs error system in the ansi build which prevents using
   FEerror inside the signal handler (i.e. when the stack is
   redirected -- one gets a second segfault in a pcl closure when
   processing the error).  FEerror works fine in the CLtL1 image.  As
   a temporary measure, I've called unwind on the top frame perforce,
   which at least allows the session to continue in both images.

2) There is some rudimentary compiler changes in the patch below which
   allows gcc to optimize the sibling calls in Eric's original example
   both when the functions are as written, and when they are
   proclaimed and 'fast-linked'.  I.e. with the lisp file:

(proclaim '(ftype (function (t t) t) test test1))
(defun test (x y)
;  (print 'hello)
  (test1 y x))
(defun test1 (x y )
;  (print 'World)
  (test y x))

(defun test2 ()
;  (print 'hello)
  (test3))
(defun test3 ( )
;  (print 'World)
  (test2))

(test 1 2) and (test) will proceed indefinitely, at least when
compiled with -O2.  gcc's -O3 is disabling one of the sibling call
optimizations for some reason -- perhaps you can discover why?

This needs more testing before committing, and I'm thinking only 2.7.x
at this stage.

Take care, 


Index: cmpnew/gcl_cmpcall.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpcall.lsp,v
retrieving revision 1.1.2.1
diff -u -r1.1.2.1 gcl_cmpcall.lsp
--- cmpnew/gcl_cmpcall.lsp      14 Sep 2003 02:30:33 -0000      1.1.2.1
+++ cmpnew/gcl_cmpcall.lsp      28 Apr 2004 21:43:36 -0000
@@ -301,10 +301,16 @@
               (close-inline-blocks)))
            (t
             (push-args args)
-            (let ((num (add-fast-link fname nil args)))
-              (wt-nl "(void) (*Lnk" num  ")(")
-              (if (get fname 'proclaimed-closure) (wt "Lclptr" num))
-              (wt  ");")
+            (let ((num (add-fast-link fname nil args))
+                  (fd (assoc fname *global-funs*))
+                  (pc (get fname 'proclaimed-closure)))
+              (if fd
+                  (if pc
+                      (wt-nl "ALLOW_SIBCALL1(Lnk" num ",L" (cdr fd) ",Lclptr" 
num ");")
+                    (wt-nl "ALLOW_SIBCALL0(Lnk" num ",L" (cdr fd) ");"))
+                (if pc
+                    (wt-nl "(void) (*Lnk" num  ")(Lclptr" num ");")
+                  (wt-nl "(void) (*Lnk" num  ")();")))
               (unwind-exit 'fun-val nil fname)))))
 
 
@@ -351,7 +357,10 @@
              (setq link-string
                    (with-output-to-string
                     (st)
-                   (format st  "(*(LnkLI~d))(" n)
+                    (let ((fd (assoc fname *global-funs*)))
+                      (if fd
+                          (format st "ALLOW_SIBCALL~d(LnkLI~d,LI~d," (if (> 
(length argtypes) 0) 1 0) n (cdr fd))
+                        (format st  "(*(LnkLI~d))(" n)))
                    (do ((com)
                         (v argtypes (cdr v))
                         (i 0 (+ 1 i)))
Index: cmpnew/gcl_cmplabel.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmplabel.lsp,v
retrieving revision 1.1.2.4
diff -u -r1.1.2.4 gcl_cmplabel.lsp
--- cmpnew/gcl_cmplabel.lsp     6 Mar 2004 14:47:27 -0000       1.1.2.4
+++ cmpnew/gcl_cmplabel.lsp     28 Apr 2004 21:43:36 -0000
@@ -169,9 +169,15 @@
                    (return-short-float short-float . wt-short-float-loc)
                    (return-long-float long-float . wt-long-float-loc)
                    (return-object t . wt-loc))))
+     (or (eq *exit* (car type.wt)) (wfs-error))
+     (setq type.wt (cdr type.wt))
+     (let ((tailc (and (not (consp *inline-blocks*)) (eql bds-bind 0) (eq 
bds-cvar nil))))
+       (when tailc
+        (wt-nl "VMR" *reservation-cmacro* "(" (if (equal (rep-type (car 
type.wt)) "long ") "(object)" ""))
+        (funcall (cdr type.wt) loc)
+        (wt ")")
+        (return)))
      (let ((cvar (next-cvar)))
-       (or (eq *exit* (car type.wt)) (wfs-error))
-       (setq type.wt (cdr type.wt))
        (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ")
        (funcall (cdr type.wt) loc)  (wt ";")
        (unwind-bds bds-cvar bds-bind)
Index: h/cmponly.h
===================================================================
RCS file: /cvsroot/gcl/gcl/h/cmponly.h,v
retrieving revision 1.6.6.1
diff -u -r1.6.6.1 cmponly.h
--- h/cmponly.h 1 Dec 2003 16:50:00 -0000       1.6.6.1
+++ h/cmponly.h 28 Apr 2004 21:43:37 -0000
@@ -74,3 +74,5 @@
 
 #define        cclosure_call   funcall
 
+#define ALLOW_SIBCALL0(a_,b_) (a_==b_ ? b_() : a_())
+#define ALLOW_SIBCALL1(a_,b_,c_...)  (a_==b_ ? b_( c_ ) :  a_( c_ ) )
Index: h/linux.h
===================================================================
RCS file: /cvsroot/gcl/gcl/h/linux.h,v
retrieving revision 1.7.6.3
diff -u -r1.7.6.3 linux.h
--- h/linux.h   4 Apr 2004 19:29:08 -0000       1.7.6.3
+++ h/linux.h   28 Apr 2004 21:43:37 -0000
@@ -80,7 +80,19 @@
 #undef HAVE_SIGVEC
 #define HAVE_SIGACTION
 /* make this a noop */
-#define SETUP_SIG_STACK
+/* #define SETUP_SIG_STACK */
+#define SETUP_SIG_STACK                                \
+{                                                      \
+static struct sigaltstack estack;                      \
+static double estack_buf [SIGSTKSZ/sizeof(double)+1];  \
+bzero(estack_buf, sizeof(estack_buf));                 \
+estack.ss_sp = (char *) &estack_buf[SIGSTKSZ/sizeof(double)]; \
+estack.ss_flags = 0;                                   \
+estack.ss_size = SIGSTKSZ;                             \
+if (sigaltstack(&estack, 0) < 0)                       \
+    FEerror("Cannot setup signal stack",0);            \
+}
+
 #ifndef HAVE_SV_ONSTACK
 #define SV_ONSTACK 0
 #endif
@@ -125,7 +137,7 @@
 
 
 #define INSTALL_SEGMENTATION_CATCHER \
-        (void) signal(SIGSEGV,segmentation_catcher)
+        (void) gcl_signal(SIGSEGV,segmentation_catcher)
 
 
 /* get the fileno of a FILE* */
Index: o/main.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/main.c,v
retrieving revision 1.26.4.1.2.18
diff -u -r1.26.4.1.2.18 main.c
--- o/main.c    23 Apr 2004 19:29:05 -0000      1.26.4.1.2.18
+++ o/main.c    28 Apr 2004 21:43:37 -0000
@@ -269,6 +269,8 @@
         if (rl.rlim_cur == RLIM_INFINITY || 
            rl.rlim_cur > MAX_STACK_SIZE)
          rl.rlim_cur=MAX_STACK_SIZE;
+/*     rl.rlim_cur/=2; */
+/*     setrlimit(RLIMIT_STACK,&rl); */
        cssize = rl.rlim_cur/4 - 4*CSGETA;
 #endif 
 #endif
@@ -610,32 +612,40 @@
        FEerror("Invocation history stack overflow.", 0);
 }
 
+static void 
+cs_overflow(void) { 
+/* #ifdef AV  */
+/*     if (cs_limit < cs_org - cssize)  */
+/*             error("control stack overflow");  */
+/*     cs_limit -= CSGETA;  */
+/* #endif  */
+/* #ifdef MV  */
+
+
+
+/* #endif  */
+/*   static int in_cs_overflow; */
+/*   if (in_cs_overflow) */
+/*     error("Recursive C stack overflow."); */
+/*   in_cs_overflow=1; */
+/*   FEerror("Control stack overflow.", 0);  */
+/*   in_cs_overflow=0; */
+  fprintf(stderr,"C stack overflow -- unwinding one level");
+  unwind(frs_top,Cnil);
+} 
+
 void
 segmentation_catcher(int i) {
-#ifndef SIG_STACK_SIZE 
+#ifdef SETUP_SIG_STACK
   int x;
-  if (&x < cs_limit)
+  if ((&x>cs_limit && &x>cs_org)
+      || (&x<cs_limit && &x<cs_org))
     cs_overflow();
   else 
     printf("Segmentation violation: c stack ok:signalling error");
 #endif
   error("Segmentation violation.");
 }
-
-/* static void */
-/* cs_overflow(void) { */
-/* #ifdef AV */
-/*     if (cs_limit < cs_org - cssize) */
-/*             error("control stack overflow"); */
-/*     cs_limit -= CSGETA; */
-/* #endif */
-/* #ifdef MV */
-
-
-
-/* #endif */
-/*     FEerror("Control stack overflow.", 0); */
-/* } */
 
 /* static void */
 /* end_of_file(void) { */
Index: o/usig.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/usig.c,v
retrieving revision 1.10.4.1
diff -u -r1.10.4.1 usig.c
--- o/usig.c    20 Jul 2003 18:00:12 -0000      1.10.4.1
+++ o/usig.c    28 Apr 2004 21:43:37 -0000
@@ -61,8 +61,7 @@
 #ifdef HAVE_SIGACTION
     struct sigaction action;
     action.sa_handler = handler;
-/*    action.sa_flags =  SA_RESTART | ((signo == SIGSEGV || signo == SIGBUS) ? 
SV_ONSTACK : 0) */
-   action.sa_flags = SA_RESTART | ((signo == SIGSEGV || signo == SIGBUS) ? 
SV_ONSTACK : 0)  
+    action.sa_flags = SA_RESTART | ((signo == SIGSEGV || signo == SIGBUS) ? 
SA_ONSTACK : 0)  
 #ifdef SA_SIGINFO
     | SA_SIGINFO
 #endif      


Eric Merritt <address@hidden> writes:

> --- Camm Maguire <address@hidden> wrote:
> > 1) I've figured out how to trap C stack overflows
> > more gracefully by
> >    looking at older GCL code.  Basically one needs
> > to define
> >    SETUP_SIG_STACK in linux.h to use sigaltstack to
> > provide an
> >    alternate stack to process the segmentation
> > signal handler.  I've
> >    done this, have tested, and it works well for me.
> >  One can continue
> >    from this condition, e.g. by quitting to the top
> > level, and
> >    restoring the stack pointer to its original
> > value.
> 
>  Very cool. This kind of response just rocks Camm. You
> and your fellow maintainers make GCL worth using.
> 
> 
> > 2) [ snip good stuff ]
> 
>  Andreas Bauer talks about very similar problems they
> had using sibcall in the ghc haskell compiler. The
> detailed descriptions he provieds in his thesis may be
> helpfull, although some of the things he talks about
> will not be available until gcc 3.4. His thesis is
> located here -> http://home.in.tum.de/~baueran/thesis/
> 
> > 
> > 3) Am going away until next Wednesday.   will try to
> > commit the
> >    sigaltstack stuff then.
> 
>   Have a good break.
> 
> 
>       
>               
> __________________________________
> Do you Yahoo!?
> Yahoo! Photos: High-quality 4x6 digital prints for 25¢
> http://photos.yahoo.com/ph/print_splash
> 
> 
> _______________________________________________
> Gcl-devel mailing list
> address@hidden
> http://mail.gnu.org/mailman/listinfo/gcl-devel
> 
> 
> 

-- 
Camm Maguire                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah