Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4322 Modified Files: arrays.lisp Log Message: Starting to support adjustable and displaced vectors. Date: Fri Jun 10 00:19:03 2005 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.50 movitz/losp/muerte/arrays.lisp:1.51 --- movitz/losp/muerte/arrays.lisp:1.50 Sun May 22 00:37:53 2005 +++ movitz/losp/muerte/arrays.lisp Fri Jun 10 00:19:02 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.50 2005/05/21 22:37:53 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.51 2005/06/09 22:19:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,10 +21,6 @@ (in-package muerte) -(defun vector-element-type (object) - (memref object (movitz-type-slot-offset 'movitz-basic-vector 'element-type) - :type :unsigned-byte8)) - (defmacro vector-double-dispatch ((s1 s2) &rest clauses) (flet ((make-double-dispatch-value (et1 et2) (+ (* #x100 (bt:enum-value 'movitz::movitz-vector-element-type et1)) @@ -33,8 +29,8 @@ #+ignore (warn "vdd: ~X" (+ (* #x100 (vector-element-type ,s1)) (vector-element-type ,s2))) - (case (+ (ash (vector-element-type ,s1) 8) - (vector-element-type ,s2)) + (case (+ (ash (vector-element-type-code ,s1) 8) + (vector-element-type-code ,s2)) ,@(loop for (keys . forms) in clauses if (atom keys) collect (cons keys forms) @@ -42,18 +38,36 @@ collect (cons (make-double-dispatch-value (first keys) (second keys)) forms)))))) -(define-compiler-macro vector-element-type (object) - `(memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'element-type) - :type :unsigned-byte8)) +(defmacro with-indirect-vector ((var form &key (check-type t)) &body body) + `(let ((,var ,form)) + ,(when check-type `(check-type ,var indirect-vector)) + (macrolet ((,var (slot) + (let ((index (position slot '(displaced-to displaced-offset + fill-pointer length)))) + (assert index () "Unknown indirect-vector slot ~S." slot) + `(memref ,',var (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index ,index)))) + ,@body))) + +(define-compiler-macro vector-element-type-code (object) + `(let ((x (memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'element-type) + :type :unsigned-byte8))) + (if (/= x ,(bt:enum-value 'movitz::movitz-vector-element-type :indirects)) + x + (memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'fill-pointer) + :index 1 :type :unsigned-byte8)))) + +(defun vector-element-type-code (object) + (vector-element-type-code object)) -(defun (setf vector-element-type) (numeric-element-type vector) +(defun (setf vector-element-type-code) (numeric-element-type vector) (check-type vector vector) (setf (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'element-type) :type :unsigned-byte8) numeric-element-type)) (defun array-element-type (array) - (ecase (vector-element-type array) + (ecase (vector-element-type-code array) (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) t) (#.(bt:enum-value 'movitz::movitz-vector-element-type :character) @@ -111,13 +125,17 @@ (defun array-dimension (array axis-number) (etypecase array + (indirect-vector + (assert (eq 0 axis-number)) + (with-indirect-vector (indirect array :check-type nil) + (indirect length))) ((simple-array * 1) - (assert (zerop axis-number)) + (assert (eq 0 axis-number)) (memref array (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))) (defun array-dimensions (array) - (check-type array array) - 1) + (etypecase array + (vector 1))) (defun shrink-vector (vector new-size) (check-type vector vector) @@ -142,13 +160,18 @@ (defun array-has-fill-pointer-p (array) (etypecase array - (simple-array + (indirect-vector + t) + ((simple-array * 1) (%basic-vector-has-fill-pointer-p array)) (array nil))) (defun fill-pointer (vector) (etypecase vector - (simple-array + (indirect-vector + (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index 2)) + ((simple-array * 1) (assert (%basic-vector-has-fill-pointer-p vector) (vector) "Vector has no fill-pointer.") (%basic-vector-fill-pointer vector)))) @@ -157,7 +180,7 @@ (check-type vector vector) (let ((length (the fixnum (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))) - (ecase (vector-element-type vector) + (ecase (vector-element-type-code vector) (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) (%shallow-copy-object vector (+ 2 length))) (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) @@ -173,14 +196,28 @@ (defun (setf fill-pointer) (new-fill-pointer vector) (etypecase vector - (simple-array + (indirect-vector (macrolet ((do-it () `(with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) new-fill-pointer vector) (:testb ,movitz:+movitz-fixnum-zmask+ :al) (:jnz 'illegal-fill-pointer) - (:movl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + (:movl (:ebx (:offset movitz-basic-vector data) 12) :ecx) + (:cmpl :ebx :ecx) + (:jg '(:sub-program (illegal-fill-pointer) + (:compile-form (:result-mode :ignore) + (error "Illegal fill-pointer: ~W." new-fill-pointer)))) + (:movl :eax (:ebx (:offset movitz-basic-vector data) 8))))) + (do-it))) + ((simple-array * 1) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) new-fill-pointer vector) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) + (:jnz 'illegal-fill-pointer) + (:movl (:ebx (:offset movitz-basic-vector num-elements)) :ecx) (:testl ,(logxor #xffffffff (1- (expt 2 14))) :ecx) (:jnz '(:sub-program () @@ -190,7 +227,7 @@ (:jc '(:sub-program (illegal-fill-pointer) (:compile-form (:result-mode :ignore) (error "Illegal fill-pointer: ~W." new-fill-pointer)))) - (:movw :ax (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::fill-pointer)))))) + (:movw :ax (:ebx (:offset movitz-basic-vector fill-pointer)))))) (do-it))))) (defun vector-aref%unsafe (vector index) @@ -263,18 +300,22 @@ (numargs-case (2 (array index) (etypecase array - (simple-array + (indirect-vector + (with-indirect-vector (indirect array :check-type nil) + (aref (indirect displaced-to) (+ index (indirect displaced-offset))))) + (vector (macrolet ((do-it () `(with-inline-assembly (:returns :eax) - (:declare-label-set basic-vector-dispatcher - ,(loop with x = (make-list 8 :initial-element 'unknown) - for et in '(:any-t :character :u8 :u32 :code :bit) - do (setf (elt x (bt:enum-value - 'movitz::movitz-vector-element-type - et)) - et) - finally (return x))) + (:declare-label-set + basic-vector-dispatcher + ,(loop with x = (make-list 8 :initial-element 'unknown) + for et in '(:any-t :character :u8 :u32 :code :bit) + do (setf (elt x (bt:enum-value + 'movitz::movitz-vector-element-type + et)) + et) + finally (return x))) (:compile-two-forms (:eax :ebx) array index) (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:testb ,movitz:+movitz-fixnum-zmask+ :bl) @@ -338,7 +379,11 @@ (numargs-case (3 (value vector index) (etypecase vector - (simple-array + (indirect-vector + (with-indirect-vector (indirect vector :check-type nil) + (setf (aref (indirect displaced-to) (+ index (indirect displaced-offset))) + value))) + (vector (macrolet ((do-it () `(with-inline-assembly (:returns :eax) @@ -512,27 +557,36 @@ ;;; string accessors (defun char (string index) - (check-type string string) (assert (below index (array-dimension string 0))) - (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) - :index index :type :character)) + (etypecase string + (simple-string + (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index index :type :character)) + (string + (with-indirect-vector (indirect string) + (char (indirect displaced-to) (+ index (indirect displaced-offset))))))) (defun (setf char) (value string index) - (check-type string string) - (check-type value character) (assert (below index (array-dimension string 0))) - (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) - :index index :type :character) value)) + (etypecase string + (simple-string + (check-type value character) + (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index index :type :character) value)) + (string + (with-indirect-vector (indirect string) + (setf (char (indirect displaced-to) (+ index (indirect displaced-offset))) + value))))) (defun schar (string index) - (check-type string string) + (check-type string simple-string) (assert (below index (length string))) (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) :index index :type :character)) (defun (setf schar) (value string index) - (check-type string string) + (check-type string simple-string) (check-type value character) (assert (below index (length string))) (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) @@ -593,23 +647,31 @@ (defun subvector-accessors (vector start end) "Check that vector is a vector, that start and end are within vector's bounds, and return accessors for that subsequence (fast & unsafe accessors, that is)." - (check-type vector vector) (when (and start end) (assert (<= 0 start end)) (assert (<= end (array-dimension vector 0)))) - (case (vector-element-type vector) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) - (values #'svref%unsafe #'(setf svref%unsafe))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :character) - (values #'char%unsafe #'(setf char%unsafe))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8) - (values #'u8ref%unsafe #'(setf u8ref%unsafe))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) - (values #'u32ref%unsafe #'(setf u32ref%unsafe))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :code) - (values #'u8ref%unsafe #'(setf u8ref%unsafe))) - (t (warn "don't know about vector's element-type: ~S" vector) - (values #'aref #'(setf aref))))) + (etypecase vector + (indirect-vector + (with-indirect-vector (indirect vector) + (if (= 0 (indirect displaced-offset)) + (values #'aref #'(setf aref)) + (let ((offset (indirect displaced-offset))) + (values (lambda (a i) (aref a (+ i offset))) + (lambda (v a i) (setf (aref a (+ i offset)) v))))))) + (vector + (case (vector-element-type-code vector) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) + (values #'svref%unsafe #'(setf svref%unsafe))) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :character) + (values #'char%unsafe #'(setf char%unsafe))) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8) + (values #'u8ref%unsafe #'(setf u8ref%unsafe))) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) + (values #'u32ref%unsafe #'(setf u32ref%unsafe))) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :code) + (values #'u8ref%unsafe #'(setf u8ref%unsafe))) + (t (warn "don't know about vector's element-type: ~S" vector) + (values #'aref #'(setf aref))))))) (defmacro with-subvector-accessor ((name vector-form &optional start end) &body body) "Installs name as an accessor into vector-form, bound by start and end." @@ -803,29 +865,125 @@ (replace array initial-contents))) array)) +(defun make-indirect-vector (displaced-to displaced-offset fill-pointer length) + (let ((x (make-basic-vector%t 4 0 nil nil))) + (setf (vector-element-type-code x) + #.(bt:enum-value 'movitz::movitz-vector-element-type :indirects)) + (set-indirect-vector x displaced-to displaced-offset + (vector-element-type-code displaced-to) + fill-pointer length))) + +(defun set-indirect-vector (x displaced-to displaced-offset et-code fill-pointer length) + (check-type displaced-to vector) + (let ((displaced-offset (or displaced-offset 0))) + (assert (<= (+ displaced-offset length) (length displaced-to)) () + "Displaced-to is outside legal range.") + (setf (memref x (movitz-type-slot-offset 'movitz-basic-vector 'fill-pointer) + :index 1 :type :unsigned-byte8) + et-code) + (with-indirect-vector (indirect x) + (setf (indirect displaced-to) displaced-to + (indirect displaced-offset) displaced-offset + (indirect fill-pointer) (etypecase fill-pointer + ((eql nil) length) + ((eql t) length) + ((integer 0 *) fill-pointer)) + (indirect length) length)) + x)) + +(defun make-basic-vector (size element-type fill-pointer initial-element initial-contents) + (let ((upgraded-element-type (upgraded-array-element-type element-type))) + (cond + ;; These should be replaced by subtypep sometime. + ((eq upgraded-element-type 'character) + (make-basic-vector%character size fill-pointer initial-element initial-contents)) + ((eq upgraded-element-type 'bit) + (make-basic-vector%bit size fill-pointer initial-element initial-contents)) + ((member upgraded-element-type '(u8 (unsigned-byte 8)) :test #'equal) + (make-basic-vector%u8 size fill-pointer initial-element initial-contents)) + ((member upgraded-element-type '(u32 (unsigned-byte 32)) :test #'equal) + (make-basic-vector%u32 size fill-pointer initial-element initial-contents)) + ((eq upgraded-element-type 'code) + (make-basic-vector%code size fill-pointer initial-element initial-contents)) + (t (make-basic-vector%t size fill-pointer initial-element initial-contents))))) + (defun make-array (dimensions &key element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset) - (declare (ignore adjustable displaced-to displaced-index-offset)) (let ((size (cond ((integerp dimensions) dimensions) ((and (consp dimensions) (null (cdr dimensions))) (car dimensions)) (t (error "Multi-dimensional arrays not supported."))))) - (let ((upgraded-element-type (upgraded-array-element-type element-type))) - (cond - ;; These should be replaced by subtypep sometime. - ((eq upgraded-element-type 'character) - (make-basic-vector%character size fill-pointer initial-element initial-contents)) - ((eq upgraded-element-type 'bit) - (make-basic-vector%bit size fill-pointer initial-element initial-contents)) - ((member upgraded-element-type '(u8 (unsigned-byte 8)) :test #'equal) - (make-basic-vector%u8 size fill-pointer initial-element initial-contents)) - ((member upgraded-element-type '(u32 (unsigned-byte 32)) :test #'equal) - (make-basic-vector%u32 size fill-pointer initial-element initial-contents)) - ((eq upgraded-element-type 'code) - (make-basic-vector%code size fill-pointer initial-element initial-contents)) - (t (make-basic-vector%t size fill-pointer initial-element initial-contents)))))) + (cond + (displaced-to + (make-indirect-vector displaced-to displaced-index-offset fill-pointer size)) + ((or adjustable + (and fill-pointer (not (typep size '(unsigned-byte 14))))) + (make-indirect-vector (make-basic-vector size element-type nil + initial-element initial-contents) + 0 fill-pointer size)) + (t (make-basic-vector size element-type fill-pointer initial-element initial-contents))))) + +(defun adjust-array (array new-dimensions + &key element-type (initial-element nil initial-element-p) + initial-contents fill-pointer + displaced-to displaced-index-offset) + (etypecase array + (indirect-vector + (let ((new-length (cond ((integerp new-dimensions) + new-dimensions) + ((and (consp new-dimensions) (null (cdr new-dimensions))) + (car new-dimensions)) + (t (error "Multi-dimensional arrays not supported."))))) + (with-indirect-vector (indirect array) + (cond + (displaced-to + (check-type displaced-to vector) + (set-indirect-vector array displaced-to displaced-index-offset + (vector-element-type-code array) + (case fill-pointer + ((nil) (indirect fill-pointer)) + ((t) new-length) + (t fill-pointer)) + new-length)) + ((and (= 0 (indirect displaced-offset)) + (/= new-length (array-dimension array 0))) + (let* ((old (indirect displaced-to)) + (new (make-array new-length :element-type (array-element-type old)))) + (dotimes (i (array-dimension old 0)) + (setf (aref new i) (aref old i))) + (when initial-element-p + (fill new initial-element :start (array-dimension old 0))) + (setf (indirect displaced-to) new + (indirect length) new-length) + (when fill-pointer + (setf (fill-pointer array) fill-pointer)))) + (t (error "Sorry, don't know how to adjust ~S." array))))) + array) + (vector + (let ((new-length (cond ((integerp new-dimensions) + new-dimensions) + ((and (consp new-dimensions) (null (cdr new-dimensions))) + (car new-dimensions)) + (t (error "Multi-dimensional arrays not supported."))))) + (let ((new (if (= (array-dimension array 0) new-length) + array + (let* ((old array) + (new (make-array new-length :element-type (array-element-type old)))) + (dotimes (i (array-dimension old 0)) + (setf (aref new i) (aref old i))) + (when initial-element-p + (fill new initial-element :start (array-dimension old 0))) + new)))) + (case fill-pointer + ((nil)) + ((t) (setf (fill-pointer new) new-length)) + (t (setf (fill-pointer new) fill-pointer))) + new))))) + +(defun adjustable-array-p (array) + (typep array 'indirect-vector)) (defun vector (&rest objects) "=> vector" @@ -863,15 +1021,19 @@ (< (fill-pointer vector) (array-dimension vector 0))) (defun vector-push-extend (new-element vector &optional extension) - (declare (ignore extension)) (check-type vector vector) (let ((p (fill-pointer vector))) - (declare (type (unsigned-byte 16) p)) (cond ((< p (array-dimension vector 0)) (setf (aref vector p) new-element (fill-pointer vector) (1+ p))) - (t (error "Vector-push extending not implemented yet."))) + ((not (adjustable-array-p vector)) + (error "Can't extend non-adjustable array.")) + (t (adjust-array vector (+ (array-dimension vector 0) + (or extension + (max 1 (array-dimension vector 0)))) + :fill-pointer (1+ p)) + (setf (aref vector p) new-element))) p))