OpenMCL 1.0 (up to head) memory corruption

--Apple-Mail-2--726762614
Content-Transfer-Encoding: 7bit
Content-Type: text/plain;
	charset=US-ASCII;
	delsp=yes;
	format=flowed

Hi,
I experience crashes when mcl runs a long time or with a lot of  
multithreaded tasks.
To test this, i wrote two small apps, an remote eval server and a  
server receiving files whose code is attached to this mail.




--Apple-Mail-2--726762614
Content-Transfer-Encoding: 7bit
Content-Type: text/x-lisp-source; x-unix-mode=0644; name="receive-test.lisp"
Content-Disposition: attachment;
	filename=receive-test.lisp

#|

this is a simple client-server app to demonstrate openmcl failing :-(
there should occur strange things from bogus objects to invocation of the kernel debugger
during 10-30 minutes 

I hope someone can show me the error in my code...
I know it is not efficient - i intentional allocate arrays producing garbage so there are enougth things
possibly being corrupted.
;; Usage:
;;
;; 1. adjust the parameter *server-base-path*
;;    the files will be created there (some 100MB's)
;;    (you can then remove the error form just above the defparameter...) 
;;    if you are suspicious about the software creating files, set *really-write-files* to nil 
;;
;; 2. in a fresh started lisp, start the server:
(load #p"home:crashtest;receive-test.lisp")
(start-server)

;; 3. stress it (from another openmcl):
(load #p"home:crashtest;receive-test.lisp")
(client-do-tests-multi :clients 50 :nsends 100000)


|#
(proclaim '(optimize (speed 0) (debug 3) (safety 3)))

(error "adjust *server-base-path* before using the code")
(defparameter *server-base-path* #p"/Volumes/BackData/tmp/")
(defparameter *really-write-files* t)

(defparameter *server-host* "localhost")
(defparameter *server-port* 7000) 



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; server code

(defvar *client-name* nil)
(defvar *stream* nil)

;; received files are put into a directory wich is unique for each client
;; so we maintain a unique client-name for each server-process

(defvar *client-counter-lock* (make-lock))
(defvar *client-counter* 0)

(defun get-new-client-name ()
  (with-lock-grabbed (*client-counter-lock*)
    (format nil "~3,'0d" (incf *client-counter*))))

(defun write-long (number stream)
  (write-byte (ldb (byte 8 24) number) stream)
  (write-byte (ldb (byte 8 16) number) stream) 
  (write-byte (ldb (byte 8 8) number) stream) 
  (write-byte (ldb (byte 8 0) number) stream))

(defun read-long (stream)
  (let ((res 0))
    (dotimes (n 4)
      (setq res (+ (ash res 8) (read-byte stream))))
    res))

(defun receive-file (counter length)
  (let ((receiving-array (make-array length :element-type '(unsigned-byte 8)))
	(path (make-pathname :name (format nil "~d" counter) :type "dat"
			     :directory (concatenate 'list (pathname-directory *server-base-path*)
						     (list *client-name*)
						     (list (format nil "~3,'0d" (mod counter 100)))))))
    ;(format T "~%will receive for ~s counter:~d size:~d" *client-name* counter length)
    (dotimes (n length)
      (setf (aref receiving-array n) (read-byte *stream*)))
    ;(format T "~%  received bytes, will write to file ~s" path)
   (if *really-write-files*
    (with-open-file (fs path :if-exists :supersede :if-does-not-exist :create :direction :output :element-type '(unsigned-byte 8))
      (write-sequence receiving-array fs))
    (let ((another-array (make-array length :element-type '(unsigned-byte 8))))
      (sleep 0.2)
      (dotimes (n length )
	(setf (aref another-array n) (aref receiving-array n)))))))

(defun start-server (&optional (port *server-port*))
  (format t "~%server starting, tries to bind port ~a" port)
  (let (sstream
        stream)
    (unwind-protect
	(progn (setf sstream (ccl::make-socket :connect :passive :local-port port :format :binary))
	       (unwind-protect
		   (loop 
		    (setq stream (ccl::accept-connection sstream))
		    (process-run-function `(:name "es" :initial-bindings ((*stream* . ,stream) (*client-name* . ,(get-new-client-name))))
					  #'server-process-connection) 
		    (setq stream nil))
		 (when stream (close stream))))
      (when sstream
	(close sstream)))
    (format t "~%buserve-listener stopped on port ~a" port)))

(defun server-process-connection ()
  (format t "~%starting for client ~s" *client-name*)
  (unwind-protect 
      (handler-case 
       (handler-bind  ((error #'(lambda (c)
				  (format *debug-io* "~%-------------- call-history condition------------------~%")
				  (describe  c) 
				  (format *debug-io* "~%-------------- call-history start ---------------------~%")
				  (ccl::print-call-history :detailed-p t)
				  (format *debug-io* "~%-------------- call-history end ---------------------~%"))))
	 (let ((counter 0))
	   (loop
	    (let* ((size (read-long *stream*)))
	      (when (zerop size)
		(return));; leave loop
	      (receive-file counter size)
	      (incf counter)))))
       (error (c)
	      (format T "~%error with client ~s" *client-name*)))
    (close *stream* :abort T)
    (setf *stream* nil)
    (format t "~%finished with client ~s" *client-name*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the client

(defmacro with-transfer-stream ((stream host port)  &body body)
  `(let ((,stream (ccl::make-socket  :remote-host ,host :remote-port ,port :format :binary)))
     (unwind-protect 
	 (progn ,@body
		(write-long 0 ,stream))  ;; logout
       (close ,stream))))

(defun client-send-thing (stream)
  (let ((size (+ 10000 (random 10000)))) 
    (write-long size stream)
    (force-output stream)
    (dotimes (n size)
      (write-byte (random 255) stream))
    (force-output stream) ))
   

(defun client-do-tests (&key (nsends 10) (host *server-host*) (port *server-port*))
  (with-transfer-stream (s host port)
    (dotimes (n nsends)
      (client-send-thing s))))

(defun client-do-tests-multi (&key (clients 100) (nsends 10000000) (host *server-host*) (port *server-port*)) 
  (dotimes (n clients)
      (process-run-function "egal" #'(lambda ()
				       (client-do-tests :nsends nsends :host host :port port)))
      (sleep 0.2))) ;; without this, some connects fail?!


--Apple-Mail-2--726762614
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline

_______________________________________________
Bug-openmcl mailing list
[email protected]
http://clozure.com/mailman/listinfo/bug-openmcl

--Apple-Mail-2--726762614--