From: Robert E. Brown <bbrown@sp...>  20030927 21:59:22

Compile and load the splay tree code below and then execute the function splay::tester2. On my Red Hat Linux 7.3 system, with a version of sbcl compiled from recent CVS sources, I get a crash in the garbage collector. Old versions of SBCL worked OK. The crash seems to happen regardless of whether the :sbthread feature is enabled or disabled. bob ======================================== transcript ======================================== loki <17> sbcllatest This is SBCL 0.8.3.88, an implementation of ANSI Common Lisp. SBCL is derived from the CMU CL system created at Carnegie Mellon University. Besides software and documentation originally created at Carnegie Mellon University, SBCL contains some software originally from the Massachusetts Institute of Technology, Symbolics Incorporated, and Xerox Corporation, and material contributed by volunteers since the release of CMU CL into the public domain. See the CREDITS file in the distribution for more information. SBCL is a free software system, provided as is, with absolutely no warranty. It is mostly in the public domain, but also includes some software copyrighted Massachusetts Institute of Technology, 1986; Symbolics, Inc., 1989, 1990, 1991, 1992; and Xerox Corporation, 1985, 1986, 1987, 1988, 1989, 1990 used under BSDstyle licenses allowing copying only under certain conditions. See the COPYING file in the distribution for more information. More information about SBCL is available at <http://sbcl.sourceforge.net/>;. * (compilefile "splay.lisp") ; compiling file "/local/toe/brown/toe/scapegoat/splay.lisp" (written 27 SEP 2003 04:10:32 PM): ; compiling top level form: ; compiling top level form: ; compiling top level form: <<< bunch of compilation messages deleted >>> ; compiling top level form: ; compilation unit finished ; printed 17 notes ; /local/toe/brown/toe/scapegoat/splay.fasl written ; compilation finished in 0:00:01 #P"/local/toe/brown/toe/scapegoat/splay.fasl" NIL NIL * (load "splay") T * (splay::tester2) Argh! gc_find_free_space failed (first_page), nbytes=16. Generation Boxed Unboxed LB LUB Alloc Waste Trig WP GCs Memage 0: 3075 0 0 0 12570696 24504 2000000 0 0 0.0000 1: 64433 21 0 0 1828960 262174624 2000000 64410 0 0.0000 2: 0 0 0 0 0 0 2000000 0 0 0.0000 3: 0 0 0 0 0 0 2000000 0 0 0.0000 4: 0 0 0 0 0 0 2000000 0 0 0.0000 5: 0 0 0 0 0 0 2000000 0 0 0.0000 6: 63543 0 0 0 1296072 258976056 0 0 0 0.0000 Total bytes allocated=15695728 fatal error encountered in SBCL pid 2245 There's no LDB in this build; exiting. waitpid : child 2245 40457000 exited loki <18> ======================================== splay.lisp ======================================== ;;; splay.lisp ;; Copyright (C) 2002, Robert E. Brown. (inpackage "CLUSER") (defpackage "SPLAY" (:documentation "An implementation of splay trees") (:use "COMMONLISP") (:export "MAKESPLAYTREE" "TREESEARCH" "TREEINSERT" "TREEDELETE")) (inpackage "SPLAY") (declaim (optimize (debug 3) (safety 0) (speed 3))) ;;;; Tree node (defclass treenode () ((left :accessor leftchild :initform nil :type (or nil treenode)) (right :accessor rightchild :initform nil :type (or nil treenode)) (key :accessor nodekey :initform (error "treenode :KEY slot not initialized") :initarg :key) (value :accessor nodevalue :initform (error "treenode :VALUE slot not initialized") :initarg :value)) (:documentation "A node in a binary tree")) (defun maketreenode (key value) "Create a treenode instance holding KEY and VALUE." (makeinstance 'treenode :key key :value value)) (defmethod printobject ((node treenode) (stream stream)) (printunreadableobject (node stream :type t :identity t) (format stream "~A[~A] (~A ~A)" (nodekey node) (nodevalue node) (leftchild node) (rightchild node))) (values)) ;;;; Binary tree (defclass binarytree () ((root :documentation "Root of the binary tree" :accessor rootnode :initform nil :type (or nil treenode)) (lessp :documentation "Is KEY1 less then KEY2?" :accessor keylessp :initform (error "binarytree :LESSP slot not initialized") :initarg :lessp :type (function (t t) boolean)) (equalp :documentation "Is KEY1 equal to KEY2?" :accessor keyequalp :initform (error "binarytree :EQUALP slot not initialized") :initarg :equalp :type (function (t t) boolean))) (:documentation "A binary tree")) (defun makebinarytree (lessp) (declare (type (function (t t) boolean) lessp)) "Create an empty binary tree." (makeinstance 'binarytree :lessp lessp :equalp #'(lambda (k1 k2) (not (or (funcall lessp k1 k2) (funcall lessp k2 k1)))))) (defmethod printobject ((tree binarytree) (stream stream)) (printunreadableobject (tree stream :type t :identity t) (princ (keylessp tree) stream) (princ #\Space stream) (princ (rootnode tree) stream)) (values)) ;;; Splay tree (defclass splaytree (binarytree) () (:documentation "A splay tree")) (defun makesplaytree (lessp) (declare (type (function (t t) boolean) lessp)) "Create an empty splay tree." (makeinstance 'splaytree :lessp lessp :equalp #'(lambda (k1 k2) (not (or (funcall lessp k1 k2) (funcall lessp k2 k1)))))) (defun splay (key lessp tree) (declare (type (function (t t) boolean) lessp)) (when (null tree) (returnfrom splay tree)) (let* ((node (maketreenode nil nil)) (l node) (r node) y) (declare (dynamicextent node)) (loop (cond ((funcall lessp key (nodekey tree)) (when (and (not (null (leftchild tree))) (funcall lessp key (nodekey (leftchild tree)))) (setq y (leftchild tree)) (setf (leftchild tree) (rightchild y)) (setf (rightchild y) tree) (setq tree y)) (when (null (leftchild tree)) (return)) (setf (leftchild r) tree) (setq r tree) (setq tree (leftchild tree))) ((funcall lessp (nodekey tree) key) (when (and (not (null (rightchild tree))) (funcall lessp (nodekey (rightchild tree)) key)) (setq y (rightchild tree)) (setf (rightchild tree) (leftchild y)) (setf (leftchild y) tree) (setq tree y)) (when (null (rightchild tree)) (return)) (setf (rightchild l) tree) (setq l tree) (setq tree (rightchild tree))) (t (return)))) (setf (rightchild l) (leftchild tree)) (setf (leftchild r) (rightchild tree)) (setf (leftchild tree) (rightchild node)) (setf (rightchild tree) (leftchild node)) tree)) (defgeneric treeinsert (key value tree) (:documentation "Insert a node that associates KEY with VALUE into TREE.")) (defmethod treeinsert (key value (tree splaytree)) (let ((new (maketreenode key value))) (when (not (null (rootnode tree))) (let* ((lessp (keylessp tree)) (tree (splay key lessp (rootnode tree)))) (declare (type (function (t t) boolean) lessp)) (cond ((funcall lessp key (nodekey tree)) (setf (leftchild new) (leftchild tree)) (setf (rightchild new) tree) (setf (leftchild tree) nil)) ((funcall lessp (nodekey tree) key) (setf (rightchild new) (rightchild tree)) (setf (leftchild new) tree) (setf (rightchild tree) nil)) (t (error "duplicate keys"))))) (setf (rootnode tree) new) tree)) (defgeneric treedelete (key tree) (:documentation "Delete the node from TREE that contains KEY.")) (defmethod treedelete (key (tree splaytree)) (when (not (null (rootnode tree))) (let* ((lessp (keylessp tree)) (equalp (keyequalp tree)) (root (splay key lessp (rootnode tree)))) (declare (type (function (t t) boolean) lessp equalp)) (when (funcall equalp key (nodevalue root)) (let (newroot) (if (null (leftchild root)) (setq newroot (rightchild root)) (progn (setq newroot (splay key (keylessp tree) (leftchild root))) (setf (rightchild newroot) (rightchild root)))) (setf (rootnode tree) newroot))))) tree) ;; ======================================== (defun splayinserttest () (let ((tree (makesplaytree #'<))) (loop for i from 0 below 1023 do (let ((key (mod (* 541 i) 1023))) (treeinsert key key tree))) tree)) (defun tester () (let ((tree (makesplaytree #'<))) (loop for i from 0 below 1023 do (let ((key (mod (* 541 i) 1023))) (treeinsert key key tree))) (loop for i from 0 below 1023 do (let ((key (mod (* 541 i) 1023))) (treedelete key tree))) tree)) (defun tester2 () (let ((tree (makesplaytree #'<))) (loop for i from 0 below 1000000 do (treeinsert i i tree)) (loop for i from 0 below 1000000 do (treedelete i tree)) tree)) 