losp/muerte/arrays.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      arrays.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Sun Feb 11 23:14:04 2001
  12 ;;;;
  13 ;;;; $Id: arrays.lisp,v 1.64 2007/04/08 16:03:53 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (require :muerte/basic-macros)
  18 (require :muerte/typep)
  19 (require :muerte/memref)
  20 (provide :muerte/arrays)
  21
  22 (in-package muerte)
  23
  24 (defmacro vector-double-dispatch ((s1 s2) &rest clauses)
  25   (flet ((make-double-dispatch-value (et1 et2)
  26            (+ (* #x100 (bt:enum-value 'movitz::movitz-vector-element-type et1))
  27               (bt:enum-value 'movitz::movitz-vector-element-type et2))))
  28     `(progn
  29        #+ignore
  30        (warn "vdd: ~X" (+ (* #x100 (vector-element-type ,s1))
  31               (vector-element-type ,s2)))
  32        (case (+ (ash (vector-element-type-code ,s1) 8)
  33                 (vector-element-type-code ,s2))
  34          ,@(loop for (keys . forms) in clauses
  35                if (atom keys)
  36                collect (cons keys forms)
  37                else
  38                collect (cons (make-double-dispatch-value (first keys) (second keys))
  39                              forms))))))
  40
  41 (defmacro with-indirect-vector ((var form &key (check-type t)) &body body)
  42   `(let ((,var ,form))
  43      ,(when check-type `(check-type ,var indirect-vector))
  44      (macrolet ((,var (slot)
  45                   (let ((index (position slot '(displaced-to displaced-offset
  46                                                 fill-pointer length))))
  47                     (assert index () "Unknown indirect-vector slot ~S." slot)
  48                     `(memref ,',var (movitz-type-slot-offset 'movitz-basic-vector 'data)
  49                              :index ,index))))
  50        ,@body)))
  51
  52 (define-compiler-macro vector-element-type-code (object)
  53   `(let ((x (memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
  54                     :type :unsigned-byte8)))
  55      (if (/= x ,(bt:enum-value 'movitz::movitz-vector-element-type :indirects))
  56          x
  57        (memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'fill-pointer)
  58                :index 1 :type :unsigned-byte8))))
  59
  60 (defun vector-element-type-code (object)
  61   (vector-element-type-code object))
  62
  63 (defun (setf vector-element-type-code) (numeric-element-type vector)
  64   (check-type vector vector)
  65   (setf (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
  66                 :type :unsigned-byte8)
  67     numeric-element-type))
  68
  69 (defun array-element-type (array)
  70   (ecase (vector-element-type-code array)
  71     (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
  72        t)
  73     (#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
  74        'character)
  75     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
  76        '(unsigned-byte 8))
  77     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16)
  78        '(unsigned-byte 16))
  79     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
  80        '(unsigned-byte 32))
  81     (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit)
  82        'bit)
  83     (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
  84        'code)))
  85
  86 (defun upgraded-array-element-type (type-specifier &optional environment)
  87   "=> upgraded-type-specifier"
  88   ;; We're in dire need of subtypep..
  89   (cond
  90    ((symbolp type-specifier)
  91     (case type-specifier
  92       ((character base-char standard-char)
  93        'character)
  94       ((code)
  95        'code)
  96       (t (let ((deriver (gethash type-specifier *derived-typespecs*)))
  97            (if (not deriver)
  98                t
  99              (upgraded-array-element-type (funcall deriver)))))))
 100    ((null type-specifier)
 101     t)
 102    ((consp type-specifier)
 103     (case (car type-specifier)
 104       ((integer)
 105        (let* ((q (cdr type-specifier))
 106               (min (if q (pop q) '*))
 107               (max (if q (pop q) '*)))
 108          (let ((min (if (consp min) (1+ (car min)) min))
 109                (max (if (consp max) (1- (car max)) max)))
 110            (cond
 111             ((or (eq min '*) (eq max '*))
 112              t)
 113             ((<= 0 min max 1)
 114              'bit)
 115             ((<= 0 min max #xff)
 116              '(unsigned-byte 8))
 117             ((<= 0 min max #xffff)
 118              '(unsigned-byte 16))
 119             ((<= 0 min max #xffffffff)
 120              '(unsigned-byte 32))))))
 121       (t (let ((deriver (gethash (car type-specifier) *derived-typespecs*)))
 122            (if (not deriver)
 123                t
 124              (upgraded-array-element-type (apply deriver (cdr type-specifier)) environment))))))
 125    (t t)))
 126
 127
 128 (defun array-dimension (array axis-number)
 129   (etypecase array
 130     (indirect-vector
 131      (assert (eq 0 axis-number))
 132      (with-indirect-vector (indirect array :check-type nil)
 133        (indirect length)))
 134     ((simple-array * 1)
 135      (assert (eq 0 axis-number))
 136      (memref array (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))
 137
 138 (defun array-dimensions (array)
 139   (let (r)
 140     (dotimes (d (array-rank array))
 141       (push (array-dimension array d) r))
 142     (nreverse r)))
 143
 144 (defun array-rank (array)
 145   (etypecase array
 146     (indirect-vector
 147      1)
 148     ((simple-array * 1)
 149      1)))
 150
 151 (defun shrink-vector (vector new-size)
 152   (check-type vector vector)
 153   (setf (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))
 154     new-size))
 155
 156 (define-compiler-macro %basic-vector-has-fill-pointer-p (vector)
 157   "Does the basic-vector have a fill-pointer?"
 158   `(with-inline-assembly (:returns :boolean-zf=1)
 159      (:compile-form (:result-mode :eax) ,vector)
 160      (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14))))
 161              (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)))))
 162
 163 (define-compiler-macro %basic-vector-fill-pointer (vector)
 164   "Return the basic-vector's fill-pointer. The result is only valid if
 165 %basic-vector-has-fill-pointer-p is true."
 166   `(with-inline-assembly (:returns :register)
 167      (:compile-form (:result-mode :register) ,vector)
 168      (:movzxw ((:result-register)
 169                ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::fill-pointer))
 170               (:result-register))))
 171
 172 (defun array-has-fill-pointer-p (array)
 173   (etypecase array
 174     (indirect-vector
 175      t)
 176     ((simple-array * 1)
 177      (%basic-vector-has-fill-pointer-p array))
 178     (array nil)))
 179
 180 (defun fill-pointer (vector)
 181   (etypecase vector
 182     (indirect-vector
 183      (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
 184              :index 2))
 185     ((simple-array * 1)
 186      (assert (%basic-vector-has-fill-pointer-p vector) (vector)
 187        "Vector has no fill-pointer.")
 188      (%basic-vector-fill-pointer vector))))
 189
 190 (defun shallow-copy-vector (vector)
 191   (check-type vector (simple-array * 1))
 192   (let ((length (the fixnum
 193                   (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))
 194     (ecase (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'element-type)
 195                    :type :unsigned-byte8)
 196       ((#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
 197         #.(bt:enum-value 'movitz::movitz-vector-element-type :indirects))
 198        (%shallow-copy-object vector (+ 2 length)))
 199       ((#.(bt:enum-value 'movitz::movitz-vector-element-type :u32))
 200        (%shallow-copy-non-pointer-object vector (+ 2 length)))
 201       ((#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
 202         #.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
 203         #.(bt:enum-value 'movitz::movitz-vector-element-type :code))
 204        (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 3 length) 4))))
 205       ((#.(bt:enum-value 'movitz::movitz-vector-element-type :u16))
 206        (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 1 length) 2))))
 207       ((#.(bt:enum-value 'movitz::movitz-vector-element-type :bit))
 208        (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 31 length) 32)))))))
 209
 210 (defun (setf fill-pointer) (new-fill-pointer vector)
 211   (etypecase vector
 212     (indirect-vector
 213      (macrolet
 214          ((do-it ()
 215             `(with-inline-assembly (:returns :eax)
 216                (:compile-two-forms (:eax :ebx) new-fill-pointer vector)
 217                (:testb ,movitz:+movitz-fixnum-zmask+ :al)
 218                (:jnz 'illegal-fill-pointer)
 219                (:movl (:ebx (:offset movitz-basic-vector data) 12) :ecx)
 220                (:cmpl :ebx :ecx)
 221                (:jg '(:sub-program (illegal-fill-pointer)
 222                        (:compile-form (:result-mode :ignore)
 223                         (error "Illegal fill-pointer: ~W." new-fill-pointer))))
 224                (:movl :eax (:ebx (:offset movitz-basic-vector data) 8)))))
 225        (do-it)))
 226     ((simple-array * 1)
 227      (macrolet
 228          ((do-it ()
 229             `(with-inline-assembly (:returns :eax)
 230                (:compile-two-forms (:eax :ebx) new-fill-pointer vector)
 231                (:testb ,movitz:+movitz-fixnum-zmask+ :al)
 232                (:jnz 'illegal-fill-pointer)
 233                (:movl (:ebx (:offset movitz-basic-vector num-elements))
 234                       :ecx)
 235                (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14))))
 236                 :ecx)
 237                (:jnz '(:sub-program ()
 238                        (:compile-form (:result-mode :ignore)
 239                         (error "Vector has no fill-pointer."))))
 240                (:cmpl :eax :ecx)
 241                (:jc '(:sub-program (illegal-fill-pointer)
 242                        (:compile-form (:result-mode :ignore)
 243                         (error "Illegal fill-pointer: ~W." new-fill-pointer))))
 244                (:movw :ax (:ebx (:offset movitz-basic-vector fill-pointer))))))
 245        (do-it)))))
 246
 247 (defun vector-aref%unsafe (vector index)
 248   "No type-checking of <vector> or <index>."
 249   (with-inline-assembly (:returns :eax)
 250     (:compile-form (:result-mode :eax) vector)
 251     (:compile-form (:result-mode :ebx) index)
 252     (:movzxb (:eax -1) :ecx)
 253     (:testl :ecx :ecx)                  ; element-type 0?
 254     (:jnz 'not-any-t)
 255     #.(cl:if (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
 256           `(:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2) :ebx)
 257         :nop)
 258     (:movl (:eax :ebx 2) :eax)
 259     (:jmp 'done)
 260
 261     not-any-t
 262     (:shrl #.movitz::+movitz-fixnum-shift+ :ebx)
 263     (:decl :ecx)                        ; element-type 1?
 264     (:jnz 'not-character)
 265     (:movb (:eax :ebx 2) :bl)
 266     (:xorl :eax :eax)
 267     (:movb :bl :ah)
 268     (:movb #.(movitz::tag :character) :al)
 269     (:jmp 'done)
 270
 271     not-character
 272     (:decl :ecx)
 273     (:jnz '(:sub-program (not-u8) (:int 62) (:jmp (:pc+ -4))))
 274     (:movzxb (:eax :ebx 2) :eax)
 275     (:shll #.movitz::+movitz-fixnum-shift+ :eax)
 276
 277     done))
 278
 279 (defun (setf vector-aref%unsafe) (value vector index)
 280   (with-inline-assembly (:returns :ebx)
 281     (:compile-form (:result-mode :ebx) value)
 282     (:compile-form (:result-mode :eax) vector)
 283     (:compile-form (:result-mode :ecx) index)
 284
 285     (:movzxb (:eax -1) :edx)
 286     (:testl :edx :edx)                  ; element-type 0?
 287     (:jnz 'not-any-t)
 288
 289     #.(cl:if (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
 290           `(:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2) :ebx)
 291         :nop)
 292
 293     (:movl :ebx (:eax :ecx 2))
 294     (:jmp 'done)
 295
 296     not-any-t
 297     (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
 298     (:decl :edx)                        ; element-type 1?
 299     (:jnz 'not-character)
 300     (:movb :bh (:eax :ecx 2))
 301     (:jmp 'done)
 302
 303     not-character
 304     (:decl :edx)
 305     (:jnz '(:sub-program (not-u8) (:int 62) (:jmp (:pc+ -4))))
 306     (:shll #.(cl:- 8 movitz::+movitz-fixnum-shift+) :ebx)
 307     (:movb :bh (:eax :ecx 2))
 308     (:shrl #.(cl:- 8 movitz::+movitz-fixnum-shift+) :ebx)
 309
 310     done))
 311
 312
 313 (defun aref (array &rest subscripts)
 314   (numargs-case
 315    (2 (array index)
 316       (etypecase array
 317         (indirect-vector
 318          (with-indirect-vector (indirect array :check-type nil)
 319            (aref (indirect displaced-to) (+ index (indirect displaced-offset)))))
 320         (vector
 321          (macrolet
 322              ((do-it ()
 323                 `(with-inline-assembly (:returns :eax)
 324                    (:declare-label-set
 325                     basic-vector-dispatcher
 326                     ,(loop with x = (make-list 8 :initial-element 'unknown)
 327                          for et in '(:any-t :character :u8 :u32 :code :bit)
 328                          do (setf (elt x (bt:enum-value
 329                                           'movitz::movitz-vector-element-type
 330                                           et))
 331                               et)
 332                          finally (return x)))
 333                    (:compile-two-forms (:eax :ebx) array index)
 334                    (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 335                    (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
 336                    (:jnz '(:sub-program (illegal-index)
 337                            (:compile-form (:result-mode :ignore)
 338                             (error "Illegal index: ~S." index))))
 339                    (:shrl 8 :ecx)
 340                    (:andl 7 :ecx)
 341                    (:cmpl :ebx
 342                           (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)))
 343                    (:jbe '(:sub-program (out-of-bounds)
 344                            (:compile-form (:result-mode :ignore)
 345                             (error "Index ~D is beyond vector length ~D."
 346                              index
 347                              (memref array
 348                               (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))))
 349                    (:jmp (:esi (:ecx 4) 'basic-vector-dispatcher
 350                                ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)))
 351
 352                    (:jnever '(:sub-program (unknown)
 353                               (:int 100)))
 354                   :u32
 355                    (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 356                           :ecx)
 357                    (:call-local-pf box-u32-ecx)
 358                    (:jmp 'return)
 359                   :u8 :code
 360                    (:movl :ebx :ecx)
 361                    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 362                    (:movzxb (:eax :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 363                             :ecx)
 364                    (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 365                    (:jmp 'return)
 366                   :character
 367                    (:movl :ebx :ecx)
 368                    (:movl :eax :ebx)
 369                    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 370                    (:movl ,(movitz:tag :character) :eax)
 371                    (:movb (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 372                           :ah)
 373                    (:jmp 'return)
 374                   :bit
 375                    (:movl :ebx :ecx)
 376                    (:movl :eax :ebx)
 377                    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 378                    (:xorl :eax :eax)
 379                    (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 380                    (:jnc 'return)
 381                    (:addl ,movitz:+movitz-fixnum-factor+ :eax)
 382                    (:jmp 'return)
 383                   :any-t
 384                    (,movitz:*compiler-nonlocal-lispval-read-segment-prefix*
 385                     :movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
 386                           :eax)
 387                   return)))
 388            (do-it)))))
 389    (t (vector &rest subscripts)
 390       (declare (ignore vector subscripts))
 391       (error "Multi-dimensional arrays not implemented."))))
 392
 393 (defun (setf aref) (value vector &rest subscripts)
 394   (numargs-case
 395    (3 (value vector index)
 396       (etypecase vector
 397         (indirect-vector
 398          (with-indirect-vector (indirect vector :check-type nil)
 399            (setf (aref (indirect displaced-to) (+ index (indirect displaced-offset)))
 400              value)))
 401         (vector
 402          (macrolet
 403              ((do-it ()
 404                 `(with-inline-assembly (:returns :eax)
 405                    (:compile-two-forms (:eax :ebx) value vector)
 406                    (:leal (:ebx ,(- (movitz:tag :other))) :ecx)
 407                    (:compile-form (:result-mode :edx) index)
 408                    (:testb 7 :cl)
 409                    (:jnz '(:sub-program (not-a-vector)
 410                            (:compile-form (:result-mode :ignore)
 411                             (error "Not a vector: ~S." vector))))
 412                    (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
 413                    (:andl #xffff :ecx)
 414                    (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
 415                    (:jnz '(:sub-program (not-an-index)
 416                            (:compile-form (:result-mode :ignore)
 417                             (error "Not a vector index: ~S." index))))
 418                    (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 419                           :edx)
 420                    (:jnc '(:sub-program (illegal-index)
 421                            (:compile-form (:result-mode :ignore)
 422                             (error "Index ~S out of range." index))))
 423                    ;; t?
 424                    (:cmpl ,(movitz:basic-vector-type-tag :any-t) :ecx)
 425                    (:jne 'not-any-t-vector)
 426                    (,movitz:*compiler-nonlocal-lispval-write-segment-prefix*
 427                     :movl :eax
 428                           (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 429                    (:jmp 'return)
 430
 431                   not-any-t-vector
 432                    ;; Character?
 433                    (:cmpl ,(movitz:basic-vector-type-tag :character) :ecx)
 434                    (:jne 'not-character-vector)
 435                    (:cmpb ,(movitz:tag :character) :al)
 436                    (:jne '(:sub-program (not-a-character)
 437                            (:compile-form (:result-mode :ignore)
 438                             (error "Not a character: ~S" value))))
 439                    (:movl :edx :ecx)
 440                    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 441                    (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 442                    (:jmp 'return)
 443
 444                   not-character-vector
 445                    ;; u8?
 446                    (:cmpl ,(movitz:basic-vector-type-tag :u8) :ecx)
 447                    (:jne 'not-u8-vector)
 448                   code-vector
 449                    (:testl ,(logxor #xffffffff (* #xff movitz:+movitz-fixnum-factor+))
 450                            :eax)
 451                    (:jne '(:sub-program (not-an-u8)
 452                            (:compile-form (:result-mode :ignore)
 453                             (error "Not an (unsigned-byte 8): ~S" value))))
 454                    (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
 455                    (:movl :edx :ecx)
 456                    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 457                    (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 458                    (:shrl ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
 459                    (:jmp 'return)
 460
 461                   not-u8-vector
 462                    ;; Code?
 463                    (:cmpl ,(movitz:basic-vector-type-tag :code) :ecx)
 464                    (:je 'code-vector)
 465
 466                    ;; u32?
 467                    (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx)
 468                    (:jne 'not-u32-vector)
 469                    (:call-local-pf unbox-u32)
 470                    (:movl :ecx
 471                           (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 472                    (:jmp 'return)
 473
 474                   not-u32-vector
 475                    ;; bit?
 476                    (:cmpl ,(movitz:basic-vector-type-tag :bit) :ecx)
 477                    (:jne 'not-bit-vector)
 478                    (:testl ,(logxor #xffffffff (* #x1 movitz:+movitz-fixnum-factor+))
 479                            :eax)
 480                    (:jne '(:sub-program (not-a-bit)
 481                            (:compile-form (:result-mode :ignore)
 482                             (error "Not a bit: ~S" value))))
 483                    (:movl :edx :ecx)
 484                    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 485
 486                    (:testl :eax :eax)
 487                    (:jnz 'set-one-bit)
 488                    (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 489                    (:jmp 'return)
 490                   set-one-bit
 491                    (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 492                    (:jmp 'return)
 493
 494                   not-bit-vector
 495                    (:compile-form (:result-mode :ignore)
 496                                   (error "Not a vector: ~S" vector))
 497                   return)
 498                 ))
 499            (do-it)))))
 500    (t (value vector &rest subscripts)
 501       (declare (ignore value vector subscripts))
 502       (error "Multi-dimensional arrays not implemented."))))
 503
 504
 505 ;;; simple-vector accessors
 506
 507 (define-compiler-macro svref%unsafe (simple-vector index)
 508   `(memref ,simple-vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
 509            :index ,index))
 510
 511 (define-compiler-macro (setf svref%unsafe) (value simple-vector index)
 512   `(setf (memref ,simple-vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
 513                  :index ,index) ,value))
 514
 515 (defun svref%unsafe (simple-vector index)
 516 ;;  (compiler-macro-call svref%unsafe simple-vector index))
 517   (with-inline-assembly (:returns :eax)
 518     (:compile-two-forms (:eax :ebx) simple-vector index)
 519     (:movl (:eax :ebx #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :eax)))
 520
 521 (defun (setf svref%unsafe) (value simple-vector index)
 522   (setf (svref%unsafe simple-vector index) value))
 523
 524 (defun svref (simple-vector index)
 525   (macrolet
 526       ((do-it ()
 527          `(with-inline-assembly (:returns :eax)
 528             (:compile-two-forms (:eax :ebx) simple-vector index)
 529             (:leal (:eax ,(- (movitz::tag :other))) :ecx)
 530             (:testb 7 :cl)
 531             (:jne '(:sub-program (not-basic-simple-vector)
 532                     (:compile-form (:result-mode :ignore)
 533                      (error "Not a simple-vector: ~S." simple-vector))))
 534             (:movl (:eax ,movitz:+other-type-offset+) :ecx)
 535             (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
 536             (:jnz '(:sub-program (illegal-index)
 537                     (:compile-form (:result-mode :ignore)
 538                      (error "Illegal index: ~S." index))))
 539             (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx)
 540             (:jne 'not-basic-simple-vector)
 541             (:cmpl :ebx (:eax (:offset movitz-basic-vector num-elements)))
 542             (:jbe 'illegal-index)
 543             (:movl (:eax :ebx (:offset movitz-basic-vector data)) :eax)
 544             )))
 545     (do-it)))
 546
 547
 548 (defun (setf svref) (value simple-vector index)
 549   (macrolet
 550       ((do-it ()
 551          `(with-inline-assembly (:returns :eax)
 552             (:compile-two-forms (:ebx :edx) simple-vector index)
 553             (:leal (:ebx ,(- (movitz::tag :other))) :ecx)
 554             (:testb 7 :cl)
 555             (:jne '(:sub-program (not-basic-simple-vector)
 556                     (:compile-form (:result-mode :ignore)
 557                      (error "Not a simple-vector: ~S." simple-vector))))
 558             (:movl (:ebx ,movitz:+other-type-offset+) :ecx)
 559             (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
 560             (:jnz '(:sub-program (illegal-index)
 561                     (:compile-form (:result-mode :ignore)
 562                      (error "Illegal index: ~S." index))))
 563             (:compile-form (:result-mode :eax) value)
 564             (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx)
 565             (:jne 'not-basic-simple-vector)
 566             (:cmpl :edx (:ebx (:offset movitz-basic-vector num-elements)))
 567             (:jbe 'illegal-index)
 568             (:movl :eax (:ebx :edx (:offset movitz-basic-vector data))))))
 569     (do-it)))
 570
 571 ;;; string accessors
 572
 573 (defun char (string index)
 574   (assert (below index (array-dimension string 0)))
 575   (etypecase string
 576     (simple-string
 577      (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
 578              :index index :type :character))
 579     (string
 580      (with-indirect-vector (indirect string)
 581        (char (indirect displaced-to) (+ index (indirect displaced-offset)))))))
 582
 583 (defun (setf char) (value string index)
 584   (assert (below index (array-dimension string 0)))
 585   (etypecase string
 586     (simple-string
 587      (check-type value character)
 588      (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
 589                    :index index :type :character) value))
 590     (string
 591      (with-indirect-vector (indirect string)
 592        (setf (char (indirect displaced-to) (+ index (indirect displaced-offset)))
 593          value)))))
 594
 595 (defun schar (string index)
 596   (check-type string simple-string)
 597   (assert (below index (length string)))
 598   (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
 599           :index index
 600           :type :character))
 601
 602 (defun (setf schar) (value string index)
 603   (check-type string simple-string)
 604   (check-type value character)
 605   (assert (below index (length string)))
 606   (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data)
 607                 :index index :type :character)
 608     value))
 609
 610 (define-compiler-macro char%unsafe (string index)
 611   `(memref ,string (movitz-type-slot-offset 'movitz-basic-vector 'data)
 612            :index ,index :type :character))
 613
 614 (defun char%unsafe (string index)
 615   (char%unsafe string index))
 616
 617 (define-compiler-macro (setf char%unsafe) (value string index)
 618   `(setf (memref ,string (movitz-type-slot-offset 'movitz-basic-vector 'data)
 619                  :index ,index :type :character) ,value))
 620
 621 (defun (setf char%unsafe) (value string index)
 622   (setf (char%unsafe string index) value))
 623
 624 ;;; bit accessors
 625
 626 (defun bit (array &rest subscripts)
 627   (numargs-case
 628    (2 (array index)
 629       (etypecase array
 630         (indirect-vector
 631          (with-indirect-vector (indirect array :check-type nil)
 632            (aref (indirect displaced-to) (+ index (indirect displaced-offset)))))
 633         (simple-bit-vector
 634          (macrolet
 635              ((do-it ()
 636                 `(with-inline-assembly (:returns :eax)
 637                    (:compile-two-forms (:eax :ebx) array index)
 638                    (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
 639                    (:jnz '(:sub-program (illegal-index)
 640                            (:compile-form (:result-mode :ignore)
 641                             (error "Illegal index: ~S." index))))
 642                    (:cmpl :ebx
 643                           (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)))
 644                    (:jbe '(:sub-program (out-of-bounds)
 645                            (:compile-form (:result-mode :ignore)
 646                             (error "Index ~D is beyond vector length ~D."
 647                              index
 648                              (memref array
 649                               (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))))
 650                   :bit
 651                    (:movl :ebx :ecx)
 652                    (:movl :eax :ebx)
 653                    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 654                    (:xorl :eax :eax)
 655                    (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 656                    (:jnc 'return)
 657                    (:addl ,movitz:+movitz-fixnum-factor+ :eax)
 658                   return)))
 659            (do-it)))))
 660    (t (vector &rest subscripts)
 661       (declare (ignore vector subscripts))
 662       (error "Multi-dimensional arrays not implemented."))))
 663
 664 (defun sbit (array &rest subscripts)
 665   (numargs-case
 666    (2 (array index)
 667       (check-type array simple-bit-vector)
 668       (macrolet
 669           ((do-it ()
 670              `(with-inline-assembly (:returns :eax)
 671                 (:compile-two-forms (:eax :ebx) array index)
 672                 (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
 673                 (:jnz '(:sub-program (illegal-index)
 674                         (:compile-form (:result-mode :ignore)
 675                          (error "Illegal index: ~S." index))))
 676                 (:cmpl :ebx
 677                        (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)))
 678                 (:jbe '(:sub-program (out-of-bounds)
 679                         (:compile-form (:result-mode :ignore)
 680                          (error "Index ~D is beyond vector length ~D."
 681                           index
 682                           (memref array
 683                            (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))))
 684                :bit
 685                 (:movl :ebx :ecx)
 686                 (:movl :eax :ebx)
 687                 (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 688                 (:xorl :eax :eax)
 689                 (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 690                 (:jnc 'return)
 691                 (:addl ,movitz:+movitz-fixnum-factor+ :eax)
 692                return)))
 693         (do-it)))
 694    (t (vector &rest subscripts)
 695       (declare (ignore vector subscripts))
 696       (error "Multi-dimensional arrays not implemented."))))
 697
 698 (defun bitref%unsafe (array index)
 699   (macrolet
 700       ((do-it ()
 701          `(with-inline-assembly (:returns :eax)
 702             (:compile-two-forms (:eax :ebx) array index)
 703             (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
 704             (:jnz '(:sub-program (illegal-index)
 705                     (:compile-form (:result-mode :ignore)
 706                      (error "Illegal index: ~S." index))))
 707            :bit
 708             (:movl :ebx :ecx)
 709             (:movl :eax :ebx)
 710             (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 711             (:xorl :eax :eax)
 712             (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 713             (:jnc 'return)
 714             (:addl ,movitz:+movitz-fixnum-factor+ :eax)
 715            return)))
 716     (do-it)))
 717
 718
 719 (defun (setf bit) (value vector &rest subscripts)
 720   (numargs-case
 721    (3 (value vector index)
 722       (check-type value bit)
 723       (etypecase vector
 724         (indirect-vector
 725          (with-indirect-vector (indirect vector :check-type nil)
 726            (setf (aref (indirect displaced-to) (+ index (indirect displaced-offset)))
 727              value)))
 728         (simple-bit-vector
 729          (macrolet
 730              ((do-it ()
 731                 `(with-inline-assembly (:returns :eax)
 732                    (:compile-two-forms (:eax :ebx) value vector)
 733                    (:compile-form (:result-mode :edx) index)
 734                    (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
 735                    (:jnz '(:sub-program (not-an-index)
 736                            (:compile-form (:result-mode :ignore)
 737                             (error "Not a vector index: ~S." index))))
 738                    (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 739                           :edx)
 740                    (:jnc '(:sub-program (illegal-index)
 741                            (:compile-form (:result-mode :ignore)
 742                             (error "Index ~S out of range." index))))
 743                    (:movl :edx :ecx)
 744                    (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 745
 746                    (:testl :eax :eax)
 747                    (:jnz 'set-one-bit)
 748                    (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 749                    (:jmp 'return)
 750                   set-one-bit
 751                    (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 752                   return)))
 753            (do-it)))))
 754    (t (value vector &rest subscripts)
 755       (declare (ignore value vector subscripts))
 756       (error "Multi-dimensional arrays not implemented."))))
 757
 758 (defun (setf sbit) (value vector &rest subscripts)
 759   (numargs-case
 760    (3 (value vector index)
 761       (check-type value bit)
 762       (macrolet
 763           ((do-it ()
 764              `(with-inline-assembly (:returns :eax)
 765                 (:compile-two-forms (:eax :ebx) value vector)
 766                 (:compile-form (:result-mode :edx) index)
 767                 (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
 768                 (:jnz '(:sub-program (not-an-index)
 769                         (:compile-form (:result-mode :ignore)
 770                          (error "Not a vector index: ~S." index))))
 771                 (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 772                        :edx)
 773                 (:jnc '(:sub-program (illegal-index)
 774                         (:compile-form (:result-mode :ignore)
 775                          (error "Index ~S out of range." index))))
 776                 (:movl :edx :ecx)
 777                 (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 778
 779                 (:testl :eax :eax)
 780                 (:jnz 'set-one-bit)
 781                 (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 782                 (:jmp 'return)
 783                set-one-bit
 784                 (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 785                return)))
 786         (do-it)))
 787    (t (value vector &rest subscripts)
 788       (declare (ignore value vector subscripts))
 789       (error "Multi-dimensional arrays not implemented."))))
 790
 791 (defun (setf bitref%unsafe) (value vector index)
 792   (macrolet
 793       ((do-it ()
 794          `(progn
 795             (check-type value bit)
 796             (with-inline-assembly (:returns :eax)
 797               (:compile-two-forms (:eax :ebx) value vector)
 798               (:compile-form (:result-mode :edx) index)
 799               (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
 800               (:jnz '(:sub-program (not-an-index)
 801                       (:compile-form (:result-mode :ignore)
 802                        (error "Not a vector index: ~S." index))))
 803               (:movl :edx :ecx)
 804               (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
 805
 806               (:testl :eax :eax)
 807               (:jnz 'set-one-bit)
 808               (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 809               (:jmp 'return)
 810              set-one-bit
 811               (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
 812              return))))
 813     (do-it)))
 814
 815 ;;; u8 accessors
 816
 817 (define-compiler-macro u8ref%unsafe (vector index)
 818   `(memref ,vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
 819            :index ,index :type :unsigned-byte8))
 820
 821 (defun u8ref%unsafe (vector index)
 822   (u8ref%unsafe vector index))
 823
 824 (define-compiler-macro (setf u8ref%unsafe) (value vector index)
 825   `(setf (memref ,vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
 826                  :index ,index :type :unsigned-byte8) ,value))
 827
 828 (defun (setf u8ref%unsafe) (value vector index)
 829   (setf (u8ref%unsafe vector index) value))
 830
 831 ;;; u32 accessors
 832
 833 (define-compiler-macro u32ref%unsafe (vector index)
 834   `(memref ,vector (movitz-type-slot-offset 'movitz-basic-vector 'data)
 835            :index ,index :type :unsigned-byte32))
 836
 837 (defun u32ref%unsafe (vector index)
 838   (compiler-macro-call u32ref%unsafe vector index))
 839
 840 (define-compiler-macro (setf u32ref%unsafe) (value vector index)
 841   (let ((var (gensym "setf-u32ref-value-")))
 842     ;; Use var so as to avoid re-boxing of the u32 value.
 843     `(let ((,var ,value))
 844        (setf (memref ,vector 2 :index ,index :type :unsigned-byte32) ,var)
 845        ,var)))
 846
 847 (defun (setf u32ref%unsafe) (value vector index)
 848   (compiler-macro-call (setf u32ref%unsafe) value vector index))
 849
 850 ;;; fast vector access
 851
 852 (defun subvector-accessors (vector &optional start end)
 853   "Check that vector is a vector, that start and end are within vector's bounds,
 854 and return basic-vector and accessors for that subsequence."
 855   (when (and start end)
 856     (assert (<= 0 start end))
 857     (assert (<= end (array-dimension vector 0))))
 858   (etypecase vector
 859     (indirect-vector
 860      (with-indirect-vector (indirect vector)
 861        (if (= 0 (indirect displaced-offset))
 862            (subvector-accessors (indirect displaced-to) start end)
 863          (let ((offset (indirect displaced-offset)))
 864            (values vector
 865                    (lambda (a i) (aref a (+ i offset)))
 866                    (lambda (v a i) (setf (aref a (+ i offset)) v)))))))
 867     (vector
 868      (case (vector-element-type-code vector)
 869        (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t)
 870           (values vector #'svref%unsafe #'(setf svref%unsafe)))
 871        (#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
 872           (values vector #'char%unsafe #'(setf char%unsafe)))
 873        (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
 874           (values vector #'u8ref%unsafe #'(setf u8ref%unsafe)))
 875        (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
 876           (values vector #'u32ref%unsafe #'(setf u32ref%unsafe)))
 877        (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
 878         (values vector #'u8ref%unsafe #'(setf u8ref%unsafe)))
 879        (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit)
 880           (values vector #'bitref%unsafe #'(setf bitref%unsafe)))
 881        (t (warn "don't know about vector's element-type: ~S" vector)
 882           (values vector #'aref #'(setf aref)))))))
 883
 884 (defmacro with-subvector-accessor ((name vector-form &optional start end) &body body)
 885   "Installs name as an accessor into vector-form, bound by start and end."
 886   (let ((reader (gensym "sub-vector-reader-"))
 887         (writer (gensym "sub-vector-writer-"))
 888         (vector (gensym "sub-vector-")))
 889     `(multiple-value-bind (,vector ,reader ,writer)
 890          (subvector-accessors ,vector-form ,start ,end)
 891        (declare (ignorable ,reader ,writer))
 892        (macrolet ((,name (index)
 893                     `(accessor%unsafe (,',reader ,',writer) ,',vector ,index)))
 894          ,@body))))
 895
 896 (defmacro accessor%unsafe ((reader writer) &rest args)
 897   (declare (ignore writer))
 898   `(funcall%unsafe ,reader ,@args))
 899
 900 (define-setf-expander accessor%unsafe ((reader writer) &rest args)
 901   ;; should collect tmp-vars from args, most probably..
 902   (let ((store-var (gensym "accessor%unsafe-store-")))
 903     (values nil nil (list store-var)
 904             `(funcall%unsafe ,writer ,store-var ,@args)
 905             `(funcall%unsafe ,reader ,@args))))
 906
 907 (defun make-basic-vector%character (length fill-pointer initial-element initial-contents)
 908   (check-type length (and fixnum (integer 0 *)))
 909   (let* ((words (+ 2 (truncate (+ length 3) 4)))
 910          (array (macrolet
 911                     ((do-it ()
 912                        `(with-non-pointer-allocation-assembly (words :fixed-size-p t
 913                                                                      :object-register :eax)
 914                           (:load-lexical (:lexical-binding length) :ecx)
 915                           (:movl ,(movitz:basic-vector-type-tag :character)
 916                                  (:eax (:offset movitz-basic-vector type)))
 917                           (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
 918                   (do-it))))
 919     (cond
 920      ((integerp fill-pointer)
 921       (setf (fill-pointer array) fill-pointer))
 922      ((or (eq t fill-pointer)
 923           (array-has-fill-pointer-p array))
 924       (setf (fill-pointer array) length)))
 925     (cond
 926      (initial-element
 927       (check-type initial-element character)
 928       (dotimes (i length)
 929         (setf (char array i) initial-element)))
 930      (initial-contents
 931       (replace array initial-contents)))
 932     array))
 933
 934 (defun make-basic-vector%u32 (length fill-pointer initial-element initial-contents)
 935   (check-type length (and fixnum (integer 0 *)))
 936   (let* ((words (+ 2 length))
 937          (array (macrolet
 938                     ((do-it ()
 939                        `(with-non-pointer-allocation-assembly (words :fixed-size-p t
 940                                                                      :object-register :eax)
 941                           (:load-lexical (:lexical-binding length) :ecx)
 942                           (:movl ,(movitz:basic-vector-type-tag :u32)
 943                                  (:eax (:offset movitz-basic-vector type)))
 944                           (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
 945                   (do-it))))
 946     (cond
 947      ((integerp fill-pointer)
 948       (setf (fill-pointer array) fill-pointer))
 949      ((or (eq t fill-pointer)
 950           (array-has-fill-pointer-p array))
 951       (setf (fill-pointer array) length)))
 952     (cond
 953      (initial-element
 954       ;; (check-type initial-element (unsigned-byte 32))
 955       (dotimes (i length)
 956         (setf (u32ref%unsafe array i) initial-element)))
 957      (initial-contents
 958       (replace array initial-contents)))
 959     array))
 960
 961 (defun make-basic-vector%u8 (length fill-pointer initial-element initial-contents)
 962   (check-type length (and fixnum (integer 0 *)))
 963   (let* ((words (+ 2 (truncate (+ length 3) 4)))
 964          (array (macrolet
 965                     ((do-it ()
 966                        `(with-non-pointer-allocation-assembly (words :fixed-size-p t
 967                                                                      :object-register :eax)
 968                           (:load-lexical (:lexical-binding length) :ecx)
 969                           (:movl ,(movitz:basic-vector-type-tag :u8)
 970                                  (:eax (:offset movitz-basic-vector type)))
 971                           (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
 972                   (do-it))))
 973     (cond
 974      ((integerp fill-pointer)
 975       (setf (fill-pointer array) fill-pointer))
 976      ((or (eq t fill-pointer)
 977           (array-has-fill-pointer-p array))
 978       (setf (fill-pointer array) length)))
 979     (cond
 980      (initial-element
 981       (check-type initial-element (unsigned-byte 8))
 982       (dotimes (i length)
 983         (setf (u8ref%unsafe array i) initial-element)))
 984      (initial-contents
 985       (replace array initial-contents)))
 986     array))
 987
 988 (defun make-basic-vector%bit (length fill-pointer initial-element initial-contents)
 989   (check-type length (and fixnum (integer 0 *)))
 990   (let* ((words (+ 2 (truncate (+ length 31) 32)))
 991          (array (macrolet
 992                     ((do-it ()
 993                        `(with-non-pointer-allocation-assembly (words :fixed-size-p t
 994                                                                      :object-register :eax)
 995                           (:load-lexical (:lexical-binding length) :ecx)
 996                           (:movl ,(movitz:basic-vector-type-tag :bit)
 997                                  (:eax (:offset movitz-basic-vector type)))
 998                           (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
 999                   (do-it))))
1000     (cond
1001      ((integerp fill-pointer)
1002       (setf (fill-pointer array) fill-pointer))
1003      ((or (eq t fill-pointer)
1004           (array-has-fill-pointer-p array))
1005       (setf (fill-pointer array) length)))
1006     (cond
1007      (initial-element
1008       (check-type initial-element bit)
1009       (dotimes (i length)
1010         (setf (aref array i) initial-element)))
1011      (initial-contents
1012       (replace array initial-contents)))
1013     array))
1014
1015 (defun make-basic-vector%code (length fill-pointer initial-element initial-contents)
1016   (check-type length (and fixnum (integer 0 *)))
1017   (let* ((words (+ 2 (truncate (+ length 3) 4)))
1018          (array (macrolet
1019                     ((do-it ()
1020                        `(with-non-pointer-allocation-assembly (words :fixed-size-p t
1021                                                                      :object-register :eax)
1022                           (:load-lexical (:lexical-binding length) :ecx)
1023                           (:movl ,(movitz:basic-vector-type-tag :code)
1024                                  (:eax (:offset movitz-basic-vector type)))
1025                           (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))))
1026                   (do-it))))
1027     (cond
1028      ((integerp fill-pointer)
1029       (setf (fill-pointer array) fill-pointer))
1030      ((or (eq t fill-pointer)
1031           (array-has-fill-pointer-p array))
1032       (setf (fill-pointer array) length)))
1033     (cond
1034      (initial-element
1035       (check-type initial-element (unsigned-byte 8))
1036       (dotimes (i length)
1037         (setf (u8ref%unsafe array i) initial-element)))
1038      (initial-contents
1039       (replace array initial-contents)))
1040     array))
1041
1042 (defun make-basic-vector%t (length fill-pointer initial-element initial-contents)
1043   (check-type length (and fixnum (integer 0 *)))
1044   (let* ((words (+ 2 length)))
1045     (cond
1046       ((<= length 8)
1047        (let ((array (macrolet
1048                         ((do-it ()
1049                            `(with-allocation-assembly (words :fixed-size-p t
1050                                                              :object-register :eax)
1051                               (:load-lexical (:lexical-binding length) :ecx)
1052                               (:movl ,(movitz:basic-vector-type-tag :any-t)
1053                                      (:eax (:offset movitz-basic-vector type)))
1054                               (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))
1055                               (:addl 4 :ecx)
1056                               (:andl -8 :ecx)
1057                               (:jz 'init-done)
1058                               (:load-lexical (:lexical-binding initial-element) :edx)
1059                               init-loop
1060                               (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4))
1061                               (:subl 4 :ecx)
1062                               (:jnz 'init-loop)
1063                               init-done
1064                               )))
1065                       (do-it))))
1066          (cond
1067            ((integerp fill-pointer)
1068             (setf (fill-pointer array) fill-pointer))
1069            ((or (eq t fill-pointer)
1070                 (array-has-fill-pointer-p array))
1071             (setf (fill-pointer array) length)))
1072          (when initial-contents
1073            (replace array initial-contents))
1074          array))
1075       (t (let* ((init-word (if (typep initial-element '(or null fixnum character))
1076                                initial-element
1077                                nil))
1078                 (array (macrolet
1079                            ((do-it ()
1080                               `(with-inline-assembly (:returns :eax)
1081                                  (:compile-form (:result-mode :eax)
1082                                                 (with-non-pointer-allocation-assembly (words :fixed-size-p t
1083                                                                                              :object-register :eax)
1084                                                   (:load-lexical (:lexical-binding length) :ecx)
1085                                                   (:movl ,(movitz:basic-vector-type-tag :u32)
1086                                                          (:eax (:offset movitz-basic-vector type)))
1087                                                   (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))
1088                                  (:load-lexical (:lexical-binding length) :ecx)
1089                                  (:addl 4 :ecx)
1090                                  (:andl -8 :ecx)
1091                                  (:jz 'init-done2)
1092                                  (:load-lexical (:lexical-binding init-word) :edx)
1093                                  init-loop2
1094                                  (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4))
1095                                  (:subl 4 :ecx)
1096                                  (:jnz 'init-loop2)
1097                                  init-done2
1098                                  (:movl ,(movitz:basic-vector-type-tag :any-t)
1099                                         (:eax (:offset movitz-basic-vector type))))))
1100                          (do-it))))
1101            (cond
1102              ((integerp fill-pointer)
1103               (setf (fill-pointer array) fill-pointer))
1104              ((or (eq t fill-pointer)
1105                   (array-has-fill-pointer-p array))
1106               (setf (fill-pointer array) length)))
1107            (cond
1108              (initial-contents
1109               (replace array initial-contents))
1110              ((not (eq init-word initial-element))
1111               (fill array initial-element)))
1112            array)))))
1113
1114 (defun make-indirect-vector (displaced-to displaced-offset fill-pointer length)
1115   (let ((x (make-basic-vector%t 4 0 nil nil)))
1116     (setf (vector-element-type-code x)
1117       #.(bt:enum-value 'movitz::movitz-vector-element-type :indirects))
1118     (set-indirect-vector x displaced-to displaced-offset
1119                          (vector-element-type-code displaced-to)
1120                          fill-pointer length)))
1121
1122 (defun set-indirect-vector (x displaced-to displaced-offset et-code fill-pointer length)
1123   (check-type displaced-to vector)
1124   (let ((displaced-offset (or displaced-offset 0)))
1125     (assert (<= (+ displaced-offset length) (length displaced-to)) ()
1126       "Displaced-to is outside legal range.")
1127     (setf (memref x (movitz-type-slot-offset 'movitz-basic-vector 'fill-pointer)
1128                   :index 1 :type :unsigned-byte8)
1129       et-code)
1130     (with-indirect-vector (indirect x)
1131       (setf (indirect displaced-to) displaced-to
1132             (indirect displaced-offset) displaced-offset
1133             (indirect fill-pointer) (etypecase fill-pointer
1134                                  ((eql nil) length)
1135                                  ((eql t) length)
1136                                  ((integer 0 *) fill-pointer))
1137             (indirect length) length))
1138     x))
1139
1140 (defun make-basic-vector (size element-type fill-pointer initial-element initial-contents)
1141   (let ((upgraded-element-type (upgraded-array-element-type element-type)))
1142     (cond
1143      ;; These should be replaced by subtypep sometime.
1144      ((eq upgraded-element-type 'character)
1145       (make-basic-vector%character size fill-pointer initial-element initial-contents))
1146      ((eq upgraded-element-type 'bit)
1147       (make-basic-vector%bit size fill-pointer initial-element initial-contents))
1148      ((member upgraded-element-type '(u8 (unsigned-byte 8)) :test #'equal)
1149       (make-basic-vector%u8 size fill-pointer initial-element initial-contents))
1150      ((member upgraded-element-type '(u32 (unsigned-byte 32)) :test #'equal)
1151       (make-basic-vector%u32 size fill-pointer initial-element initial-contents))
1152      ((eq upgraded-element-type 'code)
1153       (make-basic-vector%code size fill-pointer initial-element initial-contents))
1154      (t (make-basic-vector%t size fill-pointer initial-element initial-contents)))))
1155
1156 (defun make-array (dimensions &key element-type initial-element initial-contents adjustable
1157                                    fill-pointer displaced-to displaced-index-offset)
1158   (let ((size (cond ((integerp dimensions)
1159                      dimensions)
1160                     ((and (consp dimensions) (null (cdr dimensions)))
1161                      (car dimensions))
1162                     (t
1163                      (error "Multi-dimensional arrays not supported.")))))
1164     (cond
1165      (displaced-to
1166       (make-indirect-vector displaced-to displaced-index-offset fill-pointer size))
1167      ((or adjustable
1168           (and fill-pointer (not (typep size '(unsigned-byte 14)))))
1169       (make-indirect-vector (make-basic-vector size element-type nil
1170                                                initial-element initial-contents)
1171                             0 fill-pointer size))
1172      (t (make-basic-vector size element-type fill-pointer initial-element initial-contents)))))
1173
1174 (defun adjust-array (array new-dimensions
1175                      &key element-type (initial-element nil initial-element-p)
1176                           initial-contents fill-pointer
1177                           displaced-to displaced-index-offset)
1178   (etypecase array
1179     (indirect-vector
1180      (let ((new-length (cond ((integerp new-dimensions)
1181                               new-dimensions)
1182                              ((and (consp new-dimensions) (null (cdr new-dimensions)))
1183                               (car new-dimensions))
1184                              (t (error "Multi-dimensional arrays not supported.")))))
1185        (with-indirect-vector (indirect array)
1186          (cond
1187           (displaced-to
1188            (check-type displaced-to vector)
1189            (set-indirect-vector array displaced-to displaced-index-offset
1190                                 (vector-element-type-code array)
1191                                 (case fill-pointer
1192                                   ((nil) (indirect fill-pointer))
1193                                   ((t) new-length)
1194                                   (t fill-pointer))
1195                                 new-length))
1196           ((and (= 0 (indirect displaced-offset))
1197                 (/= new-length (array-dimension array 0)))
1198            (let* ((old (indirect displaced-to))
1199                   (new (make-array new-length :element-type (array-element-type old))))
1200              (dotimes (i (array-dimension old 0))
1201                (setf (aref new i) (aref old i)))
1202              (when initial-element-p
1203                (fill new initial-element :start (array-dimension old 0)))
1204              (setf (indirect displaced-to) new
1205                    (indirect length) new-length)
1206              (when fill-pointer
1207                (setf (fill-pointer array) fill-pointer))))
1208           (t (error "Sorry, don't know how to adjust ~S." array)))))
1209      array)
1210     (vector
1211      (let ((new-length (cond ((integerp new-dimensions)
1212                               new-dimensions)
1213                              ((and (consp new-dimensions) (null (cdr new-dimensions)))
1214                               (car new-dimensions))
1215                              (t (error "Multi-dimensional arrays not supported.")))))
1216        (let ((new (if (= (array-dimension array 0) new-length)
1217                       array
1218                     (let* ((old array)
1219                            (new (make-array new-length :element-type (array-element-type old))))
1220                       (dotimes (i (array-dimension old 0))
1221                         (setf (aref new i) (aref old i)))
1222                       (when initial-element-p
1223                         (fill new initial-element :start (array-dimension old 0)))
1224                       new))))
1225          (case fill-pointer
1226            ((nil))
1227            ((t) (setf (fill-pointer new) new-length))
1228            (t (setf (fill-pointer new) fill-pointer)))
1229          new)))))
1230
1231 (defun adjustable-array-p (array)
1232   (typep array 'indirect-vector))
1233
1234 (defun vector (&rest objects)
1235   "=> vector"
1236   (declare (dynamic-extent objects))
1237   (let* ((length (length objects))
1238          (vector (make-array length)))
1239     (do ((i 0 (1+ i))
1240          (p objects (cdr p)))
1241         ((endp p))
1242       (setf (svref vector i) (car p)))
1243     vector))
1244
1245 (defun vector-push (new-element vector)
1246   (check-type vector vector)
1247   (let ((p (fill-pointer vector)))
1248     (declare (index p))
1249     (when (< p (array-dimension vector 0))
1250       (setf (aref vector p) new-element
1251             (fill-pointer vector) (1+ p))
1252       p)))
1253
1254 (defun vector-pop (vector)
1255   (let ((p (1- (fill-pointer vector))))
1256     (assert (not (minusp p)))
1257     (setf (fill-pointer vector) p)
1258     (aref vector p)))
1259
1260 (defun vector-read (vector)
1261   "Like vector-pop, only in the other direction."
1262   (let ((x (aref vector (fill-pointer vector))))
1263     (incf (fill-pointer vector))
1264     x))
1265
1266 (defun vector-read-more-p (vector)
1267   (< (fill-pointer vector) (array-dimension vector 0)))
1268
1269 (defun vector-push-extend (new-element vector &optional extension)
1270   (check-type vector vector)
1271   (let ((p (fill-pointer vector)))
1272     (cond
1273      ((< p (array-dimension vector 0))
1274       (setf (aref vector p) new-element
1275             (fill-pointer vector) (1+ p)))
1276      ((not (adjustable-array-p vector))
1277       (error "Can't extend non-adjustable array."))
1278      (t (adjust-array vector (+ (array-dimension vector 0)
1279                                 (or extension
1280                                     (max 1 (array-dimension vector 0))))
1281                       :fill-pointer (1+ p))
1282         (setf (aref vector p) new-element)))
1283     p))
1284
1285
1286 (define-compiler-macro bvref-u16 (&whole form vector offset index &environment env)
1287   (let ((actual-index (and (movitz:movitz-constantp index env)
1288                            (movitz:movitz-eval index env))))
1289     (if (not (typep actual-index '(integer 0 *)))
1290         `(bvref-u16-fallback ,vector ,offset ,index)
1291       (let ((var (gensym)))
1292         `(let ((,var ,vector))
1293            (if (not (typep ,var 'vector-u8))
1294                (bvref-u16-fallback ,var ,offset ,index)
1295              (with-inline-assembly (:returns :untagged-fixnum-ecx)
1296                (:compile-two-forms (:eax :ecx) ,var ,offset)
1297                (:cmpl (:eax ,(bt:slot-offset 'movitz::movitz-basic-vector
1298                                              'movitz::num-elements))
1299                       :ecx)
1300                (:jnc '(:sub-program () (:int 69)))
1301                (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
1302                (:movw (:eax :ecx ,(+ actual-index (bt:slot-offset 'movitz::movitz-basic-vector
1303                                                                   'movitz::data)))
1304                       :cx)
1305                (:xchgb :cl :ch))))))))
1306
1307 (defun bvref-u16-fallback (vector offset index)
1308   (logior (ash (aref vector (+ index offset)) 8)
1309           (aref vector (+ index offset))))
1310
1311 (defun bvref-u16 (vector offset index)
1312   "View <vector> as an sequence of octets, access the big-endian 16-bit word at position <index> + <offset>."
1313   (bvref-u16 vector offset index))
1314
1315 (defun ensure-data-vector (vector start length)
1316   (let ((end (typecase vector
1317                ((simple-array (unsigned-byte 8) 1)
1318                 (array-dimension vector 0))
1319                (t (error "Not a data vector: ~S" vector)))))
1320     (assert (<= (+ start length) end) (vector)
1321       "Data vector too small.")
1322     vector))