reproducible MT segfault

I've lucked into an easily reproducible example!

This is in MT clisp newly built from source in fedora 24.
More details are available if they'll help.
I look forward to hearing about the diagnosis and cure 
from the MT experts.

in shell:
  ./lisp.run -M ./lispinit.mem
  (load ".../plain-dbg-server.lisp")

(now it's waiting at command line with prompt [2]>)

Here's the source for plain-dbg-server:
====
#-(and clisp MT)(error "this file needs MT") 
 
(setf *debug-server-port* 8225) 
 
(push :usemp *features*) 
 
(defun serve-one-debugger(socket) 
  (let ((tlist (loop for x in (mt:list-threads) with i = 0 
                 when (mt:thread-active-p x) collect (cons (incf i) x))) 
        ans) 
    (print tlist socket) 
    (format socket 
            "~&enter the number of a thread to interrupt/debug: ") 
    (setf ans (or (cdr (assoc (read socket) tlist)) 
                  ;; try to put in package ap5? 
                  (mt:current-thread))) 
    (mt:thread-interrupt 
     ans 
     :function 
     (lambda nil 
       (let ((*standard-input* socket) 
             (*standard-output* socket) 
             (*debug-io* socket) 
             (*error-output* socket) 
             (*trace-output* socket) 
             (*query-io* socket)) 
         (unwind-protect 
             (break "debug") ;; close socket when finished with break 
           (close socket))))))) 
(defun show-ut (&optional (ut (get-universal-time)))  
  (multiple-value-bind  
   (s m h d mo y) (decode-universal-time ut)  
   (format nil "~d-~d-~d ~2,'0d:~2,'0d:~2,'0d" y mo d h m s))) 
(defun new-debugger-name() 
  (format nil "debugger-~a" (show-ut))) 
(defun debug-server() 
  (let ((server (socket:socket-server *debug-server-port* 
                                      :interface "localhost"))) 
       (unwind-protect 
           (loop 
            (let ((socket (socket:socket-accept server :buffered nil))) 
              (mt:make-thread #'(lambda ()(serve-one-debugger socket)) 
                              :name (new-debugger-name)))) 
         (socket:socket-server-close server)))) 
 
(mt:make-thread #'debug-server :name "debug-server") 
====

Now in another shell:

 telnet localhost 8225 
 Trying ::1... 
 telnet: connect to address ::1: Connection refused 
 Trying 127.0.0.1... 
 Connected to localhost. 
 Escape character is '^]'. 
  
 ((1 . #<THREAD "debugger-2018-9-20 14:34:32">) (2 . #<THREAD "debug-server">) 
  (3 . #<THREAD "main thread">))  
 enter the number of a thread to interrupt/debug: 1 
 1 


[the date naming the first thread will be different, but type 1]

  
 ** - Continuable Error 
 debug 
 If you continue (by typing 'continue'): Return from BREAK loop 
 The following restarts are also available: 
 ABORT          :R1      ABORT 
 Break 1 [1]>  

Now from the break I do this defun and it segfaults.
I know this code is gibberish.  I was trying to remove junk that
didn't affect whether it crashes, and might have gone further on
that path, but was eager to send this when I discovered that all 
I needed to cause the crash was the debug server.

(defun andgenerator (vars wff gen) 
  (and 
    gen 
    `( 
      (initialstate 
 ,(unless *in-relationsize* 
  `(let (,.(setq statevars 
        (loop for g in gens unless (assoc 'test (genprops g)) 
       collect (gensym "ST"))) 
       (start-flg t) ,@(when saved '(saved-tables))) ,@(when saved '(saved-tabl\
es)) 
   #'(lambda nil 
       (prog , (setq bind (list '|Exhausted |)) 
  (cond (start-flg (setq start-flg nil) (go start)) 
        (t (go cont))) 
  GEN0CONT 
  (return t)  ;exhausted 
  start 
  ,@(let (ans check gen1 wff1) 
      (loop for g on gens do 
        (cond ((not (assoc 'test (genprops (car g)))) 
    (setq gen1 (sgen (car g)) wff1 (wff (car g))) 
    (setq check nil) 
    (push 
      `(multiple-value-setq 
         (|Exhausted | 
          ,@(cond 
       ((compoundwffp wff1) 
        (loop for var in (cadr (assoc 'output gen1)) collect nil)) 
       (t 
        (loop for var in (cdr wff1) as pos from 0 
       as temp in (cadr (assoc 'template gen1)) 
       when (eq temp 'output) collect 
       (cond 
      ((variable-p var)
       (push (list (make-evalvar 
              :evalvarname (gensym "CHK") 
              :evalvarcompare 
              (varcompare var)) 
            (name-of-var var)) 
             check) 
       (nconc bind 
       (list (evalvarname (caar check)))) 
       (evalvarname (caar check)))))))) 
         (funcall ,(pop statevars))) 
      ans) 
    (setq remainingvars (fldifference remainingvars 
          (soutput (car g))))) 
   (t 
    (push `(cond ((?? ,.(vars&rels-to-names-wff (wff (car g)))) nil) 
          (t (go ,(pack* 'gen label 'cont)))) 
          ans)))) 
      (reverse ans)) 
                (return (values nil ,@(vars-to-names 
     (soutput gen)))))))))))) 


_______________________________________________
clisp-devel mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/clisp-devel