[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Sat Apr 7 20:18:20 UTC 2007
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv25962
Modified Files:
arrays.lisp
Log Message:
make-basic-vector%t used to have an atomic-sequence that was O(N) to
the length of the vector. Consequently, with somewhat frequent
interrupts and a slightly large N, this sequence would never reach
completion. Lesson is, atomic sequences must be O(1).
--- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/03/11 22:41:45 1.61
+++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/07 20:18:20 1.62
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Sun Feb 11 23:14:04 2001
;;;;
-;;;; $Id: arrays.lisp,v 1.61 2007/03/11 22:41:45 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.62 2007/04/07 20:18:20 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -1040,36 +1040,75 @@
(defun make-basic-vector%t (length fill-pointer initial-element initial-contents)
(check-type length (and fixnum (integer 0 *)))
- (let* ((words (+ 2 length))
- (array (macrolet
- ((do-it ()
- `(with-allocation-assembly (words :fixed-size-p t
- :object-register :eax)
- (:load-lexical (:lexical-binding length) :ecx)
- (:movl ,(movitz:basic-vector-type-tag :any-t)
- (:eax (:offset movitz-basic-vector type)))
- (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))
- (:addl 4 :ecx)
- (:andl -8 :ecx)
- (:jz 'init-done)
- (:load-lexical (:lexical-binding initial-element) :edx)
- init-loop
- (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4))
- (:subl 4 :ecx)
- (:jnz 'init-loop)
- init-done
- )))
- (do-it))))
+ (let* ((words (+ 2 length)))
(cond
- ((integerp fill-pointer)
- (setf (fill-pointer array) fill-pointer))
- ((or (eq t fill-pointer)
- (array-has-fill-pointer-p array))
- (setf (fill-pointer array) length)))
- (cond
- (initial-contents
- (replace array initial-contents)))
- array))
+ ((<= length 8)
+ (let ((array (macrolet
+ ((do-it ()
+ `(with-allocation-assembly (words :fixed-size-p t
+ :object-register :eax)
+ (:load-lexical (:lexical-binding length) :ecx)
+ (:movl ,(movitz:basic-vector-type-tag :any-t)
+ (:eax (:offset movitz-basic-vector type)))
+ (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))
+ (:addl 4 :ecx)
+ (:andl -8 :ecx)
+ (:jz 'init-done)
+ (:load-lexical (:lexical-binding initial-element) :edx)
+ init-loop
+ (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4))
+ (:subl 4 :ecx)
+ (:jnz 'init-loop)
+ init-done
+ )))
+ (do-it))))
+ (cond
+ ((integerp fill-pointer)
+ (setf (fill-pointer array) fill-pointer))
+ ((or (eq t fill-pointer)
+ (array-has-fill-pointer-p array))
+ (setf (fill-pointer array) length)))
+ (when initial-contents
+ (replace array initial-contents))
+ array))
+ (t (let* ((init-word (if (typep initial-element '(or null fixnum character))
+ initial-element
+ nil))
+ (array (macrolet
+ ((do-it ()
+ `(with-inline-assembly (:returns :eax)
+ (:compile-form (:result-mode :eax)
+ (with-non-pointer-allocation-assembly (words :fixed-size-p t
+ :object-register :eax)
+ (:load-lexical (:lexical-binding length) :ecx)
+ (:movl ,(movitz:basic-vector-type-tag :u32)
+ (:eax (:offset movitz-basic-vector type)))
+ (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))
+ (:load-lexical (:lexical-binding length) :ecx)
+ (:addl 4 :ecx)
+ (:andl -8 :ecx)
+ (:jz 'init-done2)
+ (:load-lexical (:lexical-binding init-word) :edx)
+ init-loop2
+ (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4))
+ (:subl 4 :ecx)
+ (:jnz 'init-loop2)
+ init-done2
+ (:movl ,(movitz:basic-vector-type-tag :any-t)
+ (:eax (:offset movitz-basic-vector type))))))
+ (do-it))))
+ (cond
+ ((integerp fill-pointer)
+ (setf (fill-pointer array) fill-pointer))
+ ((or (eq t fill-pointer)
+ (array-has-fill-pointer-p array))
+ (setf (fill-pointer array) length)))
+ (cond
+ (initial-contents
+ (replace array initial-contents))
+ ((not (eq init-word initial-element))
+ (fill array initial-element)))
+ array)))))
(defun make-indirect-vector (displaced-to displaced-offset fill-pointer length)
(let ((x (make-basic-vector%t 4 0 nil nil)))
More information about the Movitz-cvs
mailing list