April 2007 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv26544 Modified Files: pci.lisp Log Message: For scan-pci-bus, make bus 0 the default. --- /project/movitz/cvsroot/movitz/losp/x86-pc/pci.lisp 2005/08/24 07:33:21 1.12 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/pci.lisp 2007/04/07 08:03:03 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Dec 14 22:33:42 2003 ;;;; -;;;; $Id: pci.lisp,v 1.12 2005/08/24 07:33:21 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.13 2007/04/07 08:03:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -308,7 +308,7 @@ (t (list (pop mem-keys) (logand base -16)))))) -(defun scan-pci-bus (bus) +(defun scan-pci-bus (&optional (bus 0)) (loop for device from 0 to 31 do (multiple-value-bind (vendor-id return-code) (pci-bios-config-space-word bus device 0 0)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26494 Modified Files: symbols.lisp Log Message: Add gentemp. --- /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2007/02/22 22:11:21 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2007/04/07 08:02:35 1.29 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.28 2007/02/22 22:11:21 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.29 2007/04/07 08:02:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -246,6 +246,14 @@ (make-symbol (format nil "~A~D" x (prog1 *gensym-counter* (incf *gensym-counter*))))))) +(defvar *gentemp-counter* 0) + +(defun gentemp (&optional (prefix "T") (package *package*)) + (intern (do ((name #0=(format nil "~A~D" prefix *gentemp-counter*) #0#)) + ((not (find-symbol name package)) name) + (incf *gentemp-counter*)) + package)) + (defun get (symbol indicator &optional default) (getf (symbol-plist symbol) indicator default))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26392 Modified Files: inspect.lisp Log Message: Add a recursion limit to objects-equalp. --- /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/03/16 19:50:47 1.58 +++ /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/07 08:01:41 1.59 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.58 2007/03/16 19:50:47 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.59 2007/04/07 08:01:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -268,22 +268,24 @@ (run-time-context (%shallow-copy-object old (movitz-type-word-size 'movitz-run-time-context))))) -(defun objects-equalp (x y) +(defun objects-equalp (x y &optional (limit 20)) "Basically, this verifies whether x is a shallow-copy of y, or vice versa." (assert (not (with-inline-assembly (:returns :boolean-zf=1) (:load-lexical (:lexical-binding x) :eax) (:cmpl #x13 :eax))) (x) "Checking illegal ~S for object-equalp." x) - (or (eql x y) + (or (= 0 (decf limit)) + (eql x y) (cond - ((not (objects-equalp (class-of x) (class-of y))) + ((not (objects-equalp (class-of x) (class-of y) limit)) nil) ((not (and (typep x 'pointer) (typep y 'pointer))) nil) (t (macrolet ((test (accessor &rest args) `(objects-equalp (,accessor x ,@args) - (,accessor y ,@args)))) + (,accessor y ,@args) + limit))) (typecase x (bignum (= x y))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24550 Modified Files: sequences.lisp Log Message: Fix a rather nasty bug in reduce when :end nil was specified for a vector sequence: The length never got computed and the vector would be accessed out of bounds (and so cause all sorts of strange effects). --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/03/21 20:20:33 1.35 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 07:59:31 1.36 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.35 2007/03/21 20:20:33 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.36 2007/04/07 07:59:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -124,57 +124,75 @@ ((= index end) result) (declare (index index))))))))))) (t (function sequence &key (key 'identity) from-end - (start 0) (end (length sequence)) + (start 0) end (initial-value nil initial-value-p)) (let ((start (check-the index start))) (with-funcallable (funcall-function function) (with-funcallable (key) - (case (- end start) - (0 (if initial-value-p - initial-value - (funcall-function))) - (1 (if initial-value-p - (funcall-function initial-value (key (elt sequence start))) - (key (elt sequence start)))) - (t (sequence-dispatch sequence - (list - (cond - ((not from-end) - (do* ((counter (1+ start) (1+ counter)) - (list (nthcdr start sequence)) - (result (funcall-function (if initial-value-p - initial-value - (key (pop list))) - (key (pop list))) - (funcall-function result (key (pop list))))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))) - (from-end - (do* ((counter (1+ start) (1+ counter)) - (list (nreverse (subseq sequence start end))) - (result (funcall-function (key (pop list)) - (if initial-value-p - initial-value - (key (pop list)))) - (funcall-function (key (pop list)) result))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))))) - (vector - (when from-end - (error "REDUCE from-end on vectors is not implemented.")) - (with-subvector-accessor (sequence-ref sequence start end) - (do* ((index start) - (result (funcall-function (if initial-value-p - initial-value - (key (sequence-ref (prog1 index (incf index))))) - (key (sequence-ref (prog1 index (incf index))))) - (funcall-function result (sequence-ref (prog1 index (incf index)))))) - ((= index end) result) - (declare (index index)))))))))))))) + (sequence-dispatch sequence + (list + (let ((list (nthcdr start sequence))) + (cond + ((null list) + (if initial-value-p + initial-value + (funcall-function))) + ((null (cdr list)) + (if initial-value-p + (funcall-function initial-value (key (car list))) + (key (car list)))) + ((not from-end) + (if (not end) + (do ((result (funcall-function (if initial-value-p + initial-value + (key (pop list))) + (key (pop list))) + (funcall-function result (key (pop list))))) + ((null list) result)) + (do ((counter (1+ start) (1+ counter)) + (result (funcall-function (if initial-value-p + initial-value + (key (pop list))) + (key (pop list))) + (funcall-function result (key (pop list))))) + ((or (null list) + (= end counter)) + result) + (declare (index counter))))) + (from-end + (do* ((end (or end (+ start (length list)))) + (counter (1+ start) (1+ counter)) + (list (nreverse (subseq sequence start end))) + (result (funcall-function (key (pop list)) + (if initial-value-p + initial-value + (key (pop list)))) + (funcall-function (key (pop list)) result))) + ((or (null list) + (= end counter)) + result) + (declare (index counter))))))) + (vector + (when from-end + (error "REDUCE from-end on vectors is not implemented.")) + (let ((end (or (check-the index end) + (length sequence)))) + (case (- end start) + (0 (if initial-value-p + initial-value + (funcall-function))) + (1 (if initial-value-p + (funcall-function initial-value (key (elt sequence start))) + (key (elt sequence start)))) + (t (with-subvector-accessor (sequence-ref sequence start end) + (do* ((index start) + (result (funcall-function (if initial-value-p + initial-value + (key (sequence-ref (prog1 index (incf index))))) + (key (sequence-ref (prog1 index (incf index))))) + (funcall-function result (sequence-ref (prog1 index (incf index)))))) + ((= index end) result) + (declare (index index))))))))))))))) (defun subseq (sequence start &optional end) (sequence-dispatch sequence @@ -1569,6 +1587,25 @@ (right (1- end)) left-item right-item) (declare (index left right)) + ;; do median-of-three.. + (let ((p1 (vector-ref start)) + (p2 (vector-ref (+ start cut-off -1))) + (p3 (vector-ref (1- end)))) + (let ((kp1 (key p1)) + (kp2 (key p2)) + (kp3 (key p3))) + (cond + ((predicate p1 p2) + (if (predicate p2 p3) + (setf pivot p2 keyed-pivot kp2) + (if (predicate p1 p3) + (setf pivot p3 keyed-pivot kp3) + (setf pivot p1 keyed-pivot kp1)))) + ((predicate p2 p3) + (if (predicate p1 p3) + (setf pivot p1 keyed-pivot kp1) + (setf pivot p3 keyed-pivot kp3))) + (t (setf pivot p2 keyed-pivot kp2))))) partitioning-loop (do-while (not (predicate keyed-pivot (key (setf left-item (vector-ref left))))) (incf left) @@ -1586,8 +1623,10 @@ partitioning-complete (setf (vector-ref start) right-item ; (aref vector right) (vector-ref right) pivot) - (quick-sort vector predicate key start right cut-off) - (quick-sort vector predicate key (1+ right) end cut-off)))))))) + (when (and (> cut-off (- right start)) + (> cut-off (- end right))) + (quick-sort vector predicate key start right cut-off) + (quick-sort vector predicate key (1+ right) end cut-off))))))))) vector) (defun sort (sequence predicate &key (key 'identity))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24391 Modified Files: integers.lisp Log Message: Fix bug that would return nil from (- nil 0) rather than err. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/05/02 20:02:09 1.122 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2007/04/07 07:56:45 1.123 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.122 2006/05/02 20:02:09 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.123 2007/04/07 07:56:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -622,7 +622,7 @@ (macrolet ((do-it () `(number-double-dispatch (minuend subtrahend) - ((t (eql 0)) + ((number (eql 0)) minuend) (((eql 0) t) (- subtrahend))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 05 Apr '07

05 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29180 Modified Files: scavenge.lisp Log Message: In map-header-vals fix scanning of not-entirely-initialized funobjs. Add map-header-vals*, mostly as a debugging tool. --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 22:13:55 1.59 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/05 21:12:19 1.60 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.59 2007/03/16 22:13:55 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.60 2007/04/05 21:12:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -40,6 +40,11 @@ (unless (eq object new-object) (setf (memref location 0) new-object))))))) +(defun map-header-vals* (function &optional (vector (%run-time-context-slot nil 'nursery-space))) + (check-type vector (vector (unsigned-byte 32))) + (let ((location (+ 2 (object-location vector)))) + (map-header-vals function location (+ location (length vector))))) + (defun map-header-vals (function start-location end-location) "Map function over each potential pointer word between start-location and end-location." @@ -106,7 +111,9 @@ (record-scan (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointers specially.. (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector)) - (new-code-vector (map-instruction-pointer function scan old-code-vector))) + (new-code-vector (if (eq 0 old-code-vector) + 0 ; i.e. a non-initialized funobj. + (map-instruction-pointer function scan old-code-vector)))) (cond ((not (eq new-code-vector old-code-vector)) ;; Code-vector%1op

1 0

[movitz-cvs] CVS movitz
by ffjeld 05 Apr '07

05 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29011 Modified Files: compiler.lisp Log Message: Fix a bug in code for initializing a stack-allocated funobj: The initial code-vector slot should be 2 rather than 0 in order to be GC-safe. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/21 19:57:52 1.185 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/04/05 21:10:39 1.186 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.185 2007/03/21 19:57:52 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.186 2007/04/05 21:10:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -7417,7 +7417,7 @@ (:pushl 0) ; %3op (:pushl 0) ; %2op (:pushl 0) ; %1op - (:pushl 0) ; (default) + (:pushl 2) ; (default) 2 is recognized by map-header-vals as non-initialized funobj. (:pushl (:eax ,(slot-offset 'movitz-funobj 'type))) (:leal (:esp ,(tag :other)) :ebx)

1 0

[movitz-cvs] CVS movitz
by ffjeld 02 Apr '07

02 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29414 Modified Files: special-operators-cl.lisp Log Message: For the block special operator, we need to ensure that the body-code resets the stack-pointer (which it won't, for result-mode :function). This fixes a hard crash on ansi-test assoc.25. --- /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/03/19 21:09:26 1.51 +++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/02 20:54:34 1.52 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.51 2007/03/19 21:09:26 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.52 2007/04/02 20:54:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -860,7 +860,9 @@ (compiler-values-bind (&code block-code &functional-p block-no-side-effects-p) (compiler-call #'compile-form :defaults forward - :result-mode block-result-mode + :result-mode (case block-result-mode + (:function :multiple-values) ; must restore stack + (t block-result-mode)) :form `(muerte.cl:progn ,@body) :env block-env) (let ((label-set-name (gensym "block-label-set-"))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 01 Apr '07

01 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12646 Modified Files: arithmetic-macros.lisp Log Message: Removed useless check-type in * compiler-macro. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/04/01 19:05:07 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/04/01 19:22:22 1.19 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.18 2007/04/01 19:05:07 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.19 2007/04/01 19:22:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -257,7 +257,6 @@ `(* ,(movitz:movitz-eval factor2 env) ,factor1)) ((movitz:movitz-constantp factor1 env) (let ((f1 (movitz:movitz-eval factor1 env))) - (check-type f1 integer) (case f1 (0 `(progn ,factor2 0)) (1 factor2)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 01 Apr '07

01 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9951 Modified Files: arithmetic-macros.lisp Log Message: Remove unreachable code. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/03/20 22:40:41 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/04/01 19:05:07 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.17 2007/03/20 22:40:41 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.18 2007/04/01 19:05:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,9 +43,7 @@ (:testb 1 :cl))) (define-compiler-macro + (&whole form &rest operands &environment env) - (flet ((term (x) (if (and nil (symbolp x)) - (gensym (format nil "term-~A-" x)) - (gensym "term-")))) + (flet ((term (x) (gensym "term-"))) (case (length operands) (0 0) (1 (first operands))

1 0