losp/muerte/io-port.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:      io-port.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Wed Mar 21 22:14:08 2001
  12 ;;;;
  13 ;;;; $Id: io-port.lisp,v 1.20 2005/09/18 16:21:25 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (require :muerte/basic-macros)
  18 (require :muerte/setf)
  19 (require :muerte/loop)
  20 (require :muerte/equalp)
  21 (provide :muerte/io-port)
  22
  23 (in-package muerte)
  24
  25 (define-compiler-macro io-port (&whole form port type &environment env)
  26   (if (not (movitz:movitz-constantp type env))
  27       form
  28     (ecase (movitz:movitz-eval type env)
  29       (:unsigned-byte8
  30        `(with-inline-assembly-case (:type (unsigned-byte 8))
  31           (do-case (:untagged-fixnum-ecx :untagged-fixnum-ecx)
  32             (:compile-form (:result-mode :edx) ,port)
  33             (:std)                      ; only EBX is now GC root
  34             (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
  35             (:xorl :eax :eax)
  36             (:inb :dx :al)
  37             (:movl :eax :ecx)
  38             (:movl :edi :eax)
  39             (:movl :edi :edx)
  40             (:cld))
  41           (do-case (t :eax)
  42             (:compile-form (:result-mode :edx) ,port)
  43             (:std)                      ; only EBX is now GC root
  44             (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
  45             (:xorl :eax :eax)
  46             (:inb :dx :al)
  47             (:shll ,movitz:+movitz-fixnum-shift+ :eax)
  48             (:movl :edi :edx)
  49             (:cld))))
  50       (:unsigned-byte16
  51        `(with-inline-assembly-case (:type (unsigned-byte 16))
  52           (do-case (:untagged-fixnum-ecx :untagged-fixnum-ecx)
  53             (:compile-form (:result-mode :edx) ,port)
  54             (:std)
  55             (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
  56             (:xorl :eax :eax)
  57             (:inw :dx :ax)
  58             (:movl :eax :ecx)
  59             (:movl :edi :eax)
  60             (:movl :edi :edx)
  61             (:cld))
  62           (do-case (t :eax)
  63             (:compile-form (:result-mode :edx) ,port)
  64             (:std)
  65             (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
  66             (:xorl :eax :eax)
  67             (:inw :dx :ax)
  68             (:shll ,movitz:+movitz-fixnum-shift+ :eax)
  69             (:movl :edi :edx)
  70             (:cld))))
  71       (:unsigned-byte32
  72        `(with-inline-assembly (:returns :untagged-fixnum-ecx
  73                                         :type (unsigned-byte 32))
  74           (:compile-form (:result-mode :edx) ,port)
  75           (:std)
  76           (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
  77           (:inl :dx :eax)
  78           (:movl :eax :ecx)
  79           (:movl :edi :eax)
  80           (:movl :edi :edx)
  81           (:cld)))
  82       (:location
  83        `(with-inline-assembly (:returns :eax :type fixnum)
  84           (:compile-form (:result-mode :edx) ,port)
  85           (:std)
  86           (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
  87           (:inl :dx :eax)
  88           (:andl -8 :eax)
  89           (:movl :edi :edx)
  90           (:cld)))
  91       (:character
  92        `(with-inline-assembly (:returns :eax)
  93           (:compile-form (:result-mode :edx) ,port)
  94           (:std)
  95           (:shrl ,movitz:+movitz-fixnum-shift+ :edx)
  96           (:xorl :eax :eax)
  97           (:inb :dx :al)
  98           (:shll 8 :eax)
  99           (:movb ,(movitz::tag :character) :al)
 100           (:movl :edi :edx)
 101           (:cld))))))
 102
 103 (defun io-port (port type)
 104   (ecase type
 105     (:unsigned-byte8
 106      (io-port port :unsigned-byte8))
 107     (:unsigned-byte16
 108      (io-port port :unsigned-byte16))
 109     (:unsigned-byte32
 110      (io-port port :unsigned-byte32))
 111     (:location
 112      (io-port port :location))
 113     (:character
 114      (io-port port :character))))
 115
 116 (define-compiler-macro (setf io-port) (&whole form value port type &environment env)
 117   (let ((value-var (gensym "(setf io-port)-value-"))
 118         (port-var (gensym "(setf io-port)-port-")))
 119     (cond
 120      ((and (movitz:movitz-constantp type env)
 121            (movitz:movitz-constantp port env))
 122       (let ((the-port (movitz:movitz-eval port env))
 123             (the-type (movitz:movitz-eval type env)))
 124         (etypecase the-port
 125           ((unsigned-byte 8)            ; short form of outb can be used
 126            (ecase the-type
 127              (:unsigned-byte8
 128               `(let ((,value-var ,value))
 129                  (with-inline-assembly (:returns :nothing)
 130                    (:load-lexical (:lexical-binding ,value-var) :eax)
 131                    (:std)
 132                    (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
 133                    (:outb :al ,the-port)
 134                    (:movl :edi :eax)
 135                    (:movl :edi :edx)
 136                    (:cld))
 137                  ,value-var))
 138              (:unsigned-byte16
 139               `(let ((,value-var ,value))
 140                  (with-inline-assembly (:returns :nothing)
 141                    (:load-lexical (:lexical-binding ,value-var) :eax)
 142                    (:std)
 143                    (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
 144                    (:outw :ax ,the-port)
 145                    (:movl :edi :eax)
 146                    (:movl :edi :edx)
 147                    (:cld))
 148                  ,value-var))))
 149           ((unsigned-byte 16)           ; indirect (by DX) form of outb must be used
 150            (ecase the-type
 151              (:unsigned-byte8
 152               `(let ((,value-var ,value))
 153                  (with-inline-assembly (:returns :nothing)
 154                    (:load-lexical (:lexical-binding ,value-var) :eax)
 155                    (:std)
 156                    ,@(movitz::make-immediate-move the-port :edx)
 157                    (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
 158                    (:outb :al :dx)
 159                    ,@(unless (= 0 (mod the-port 4))
 160                        `((:movl :edi :edx)))
 161                    (:movl :edi :eax)
 162                    (:cld))
 163                  ,value-var))
 164              (:unsigned-byte16
 165               `(let ((,value-var ,value))
 166                  (with-inline-assembly (:returns :nothing)
 167                    (:load-lexical (:lexical-binding ,value-var) :eax)
 168                    (:std)
 169                    ,@(movitz::make-immediate-move the-port :edx)
 170                    (:shrl ,movitz:+movitz-fixnum-shift+ :eax)
 171                    (:outw :ax :dx)
 172                    ,@(unless (= 0 (mod the-port 4))
 173                        `((:movl :edi :edx)))
 174                    (:movl :edi :eax)
 175                    (:cld)))))))))
 176      ((and (movitz:movitz-constantp type env)
 177            (movitz:movitz-constantp value env))
 178       (let ((value (movitz:movitz-eval value env)))
 179         (ecase (movitz:movitz-eval type env)
 180           (:unsigned-byte8
 181            (check-type value (unsigned-byte 8))
 182            `(let ((,port-var ,port))
 183               (with-inline-assembly (:returns :nothing)
 184                 (:load-lexical (:lexical-binding ,port-var) :untagged-fixnum-ecx)
 185                 (:std)
 186                 (:movl :ecx :edx)
 187                 (:movb ,value :al)
 188                 (:outb :al :dx)
 189                 (:movl :edi :edx)
 190                 (:movl :edi :eax)
 191                 (:cld))
 192               ,value))
 193           (:unsigned-byte16
 194            (check-type value (unsigned-byte 16))
 195            `(let ((,port-var ,port))
 196               (with-inline-assembly (:returns :nothing)
 197                 (:load-lexical (:lexical-binding ,port-var) :untagged-fixnum-ecx)
 198                 (:std)
 199                 (:movl :ecx :edx)
 200                 (:movl ,value :eax)
 201                 (:outw :ax :dx)
 202                 (:movl :edi :edx)
 203                 (:movl :edi :eax)
 204                 (:cld))
 205               ,value))
 206           (:unsigned-byte32
 207            `(let ((,port-var ,port))
 208               (with-inline-assembly (:returns :nothing)
 209                 (:load-lexical (:lexical-binding ,port-var) :untagged-fixnum-ecx)
 210                 (:std)
 211                 (:movl :ecx :edx)
 212                 (:movl ,value :eax)
 213                 (:outl :eax :dx)
 214                 (:movl :edi :edx)
 215                 (:movl :edi :eax)
 216                 (:cld))
 217               ,value))
 218           (:character
 219            `(let ((,port-var ,port))
 220               (check-type value character)
 221               (with-inline-assembly (:returns :nothing)
 222                 (:load-lexical (:lexical-binding ,port-var) :untagged-fixnum-ecx)
 223                 (:std)
 224                 (:movl :ecx :edx)
 225                 (:movb ,(char-code value) :al)
 226                 (:outb :al :dx)
 227                 (:movl :edi :edx)
 228                 (:movl :edi :eax)
 229                 (:cld))
 230               ,value)))))
 231      ((movitz:movitz-constantp type env)
 232       (ecase (movitz:movitz-eval type env)
 233         (:unsigned-byte8
 234          `(let ((,value-var ,value)
 235                 (,port-var ,port))
 236             (with-inline-assembly (:returns :nothing)
 237               (:load-lexical (:lexical-binding ,port-var) :edx)
 238               (:load-lexical (:lexical-binding ,value-var) :eax)
 239               (:std)
 240               (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 241               (:shrl ,movitz::+movitz-fixnum-shift+ :eax)
 242               (:outb :al :dx)
 243               (:movl :edi :edx)
 244               (:movl :edi :eax)
 245               (:cld))
 246             ,value-var))
 247         (:unsigned-byte16
 248          `(let ((,value-var ,value)
 249                 (,port-var ,port))
 250             (with-inline-assembly (:returns :nothing)
 251               (:load-lexical (:lexical-binding ,port-var) :edx)
 252               (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx)
 253               (:std)
 254               (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 255               (:movl :ecx :eax)
 256               (:outw :ax :dx)
 257               (:movl :edi :edx)
 258               (:movl :edi :eax)
 259               (:cld))
 260             ,value-var))
 261         (:unsigned-byte32
 262          `(let ((,value-var ,value)
 263                 (,port-var ,port))
 264             (with-inline-assembly (:returns :untagged-fixnum-ecx)
 265               (:load-lexical (:lexical-binding ,port-var) :edx)
 266               (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx)
 267               (:std)
 268               (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 269               (:movl :ecx :eax)
 270               (:outl :eax :dx)
 271               (:movl :edi :edx)
 272               (:movl :edi :eax)
 273               (:cld))))
 274         (:location
 275          `(let ((,value-var ,value)
 276                 (,port-var ,port))
 277             (with-inline-assembly (:returns :nothing)
 278               (:load-lexical (:lexical-binding ,port-var) :edx)
 279               (:load-lexical (:lexical-binding ,value-var) :eax)
 280               (:andl -8 :eax)
 281               (:std)
 282               (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 283               (:outl :eax :dx)
 284               (:movl :edi :edx)
 285               (:movl :edi :eax)
 286               (:cld))
 287             ,value-var))
 288         (:character
 289          `(let ((,value-var ,value)
 290                 (,port-var ,port))
 291             (with-inline-assembly (:returns :nothing)
 292               (:load-lexical (:lexical-binding ,port-var) :edx)
 293               (:load-lexical (:lexical-binding ,value-var) :eax)
 294               (:std)
 295               (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 296               (:shrl 8 :eax)
 297               (:outb :al :dx)
 298               (:movl :edi :edx)
 299               (:movl :edi :eax)
 300               (:cld))
 301             ,value-var))))
 302      (t form))))
 303
 304 (defun (setf io-port) (value port type)
 305   (ecase type
 306     (:unsigned-byte8
 307      (setf (io-port port :unsigned-byte8) value))
 308     (:unsigned-byte16
 309      (setf (io-port port :unsigned-byte16) value))
 310     (:unsigned-byte32
 311      (setf (io-port port :unsigned-byte32) value))
 312     (:location
 313      (setf (io-port port :location) value))
 314     (:character
 315      (setf (io-port port :character) value))))
 316
 317 ;;; The io-registerX functions are just syntactic sugar that matches the
 318 ;;; most frequent use of io-port.
 319
 320 (define-compiler-macro io-register8 (io-base io-offset)
 321   `(io-port (+ ,io-base ,io-offset) :unsigned-byte8))
 322
 323 (defun io-register8 (io-base io-offset)
 324   "Read from single-octet IO-port io-base + io-offset."
 325   (io-register8 io-base io-offset))
 326
 327 (define-compiler-macro (setf io-register8) (value io-base io-offset)
 328   `(setf (io-port (+ ,io-base ,io-offset) :unsigned-byte8) ,value))
 329
 330 (defun (setf io-register8) (value io-base io-offset)
 331   "Write to single-octet IO-port io-base + io-offset."
 332   (setf (io-register8 io-base io-offset) value))
 333
 334 (defmacro with-io-register-syntax ((name io-base-form) &body body)
 335   "Syntax for easy access to IO registers. <name> is installed as a local macro
 336 that reads from <io-base-form> plus some offset."
 337   (let ((io-var (gensym "io-base-")))
 338     `(let ((,io-var (check-the (unsigned-byte 16) ,io-base-form)))
 339        (let ((,name ,io-var))
 340          (declare (ignorable ,name))
 341          (macrolet ((,name (offset &optional (type :unsigned-byte8))
 342                       `(io-port (+ ,',io-var ,offset) ,type)))
 343            ,@body)))))
 344
 345 (define-compiler-macro io-register8x2 (io-base offset-hi offset-lo)
 346   `(let ((io-base ,io-base))
 347      (dpb (io-register8 io-base ,offset-hi)
 348           (byte 8 8)
 349           (io-register8 io-base ,offset-lo))))
 350
 351 (defun io-register8x2 (io-base offset-hi offset-lo)
 352   (io-register8x2 io-base offset-hi offset-lo))
 353
 354 (define-compiler-macro (setf io-register8x2) (&environment env value io-base offset-hi offset-lo)
 355   `(let ((value ,value))
 356      (setf (io-register8 ,io-base ,offset-hi) (ldb (byte 8 8) value)
 357            (io-register8 ,io-base ,offset-lo) (ldb (byte 8 0) value))
 358      value))
 359
 360 (defun (setf io-register8x2) (value io-base offset-hi offset-lo)
 361   (setf (io-register8x2 io-base offset-hi offset-lo) value))
 362
 363 ;;;
 364
 365 (defun io-delay (&optional (x 1000))
 366   (dotimes (i x)
 367     (with-inline-assembly (:returns :nothing) (:nop))))
 368
 369 (define-compiler-macro %io-port-read-succession (&whole form port object offset start end byte-size
 370                                                  &environment env)
 371   (if (not (movitz:movitz-constantp byte-size env))
 372       form
 373     (let ((port-var (gensym "port-var-"))
 374           (object-var (gensym "object-var-"))
 375           (byte-size (movitz:movitz-eval byte-size env)))
 376       (cond
 377        ((and (movitz:movitz-constantp offset env)
 378              (movitz:movitz-constantp start env)
 379              (movitz:movitz-constantp end env))
 380         (let* ((offset (movitz:movitz-eval offset env))
 381                (start (movitz:movitz-eval start env))
 382                (end (movitz:movitz-eval end env))
 383                (count (- end start)))
 384           (check-type count (integer 0 #x10000))
 385           (case byte-size
 386             (:32-bit
 387              (assert (= 4 movitz:+movitz-fixnum-factor+))
 388              (if (<= 1 count 20)
 389                  `(let ((,port-var ,port)
 390                         (,object-var ,object))
 391                     (with-inline-assembly-case ()
 392                       (do-case (t :eax)
 393                         (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 394                         (:std)
 395                         (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 396                         ,@(loop for i from start below end
 397                               appending
 398                                 `((:inl :dx :eax)
 399                                   (:movl :eax (:ebx ,(+ offset (* 4 i))))))
 400                         (:movl :edi :edx)
 401                         (:movl :ebx :eax)
 402                         (:cld))))
 403                `(let ((,port-var ,port)
 404                       (,object-var ,object))
 405                   (with-inline-assembly-case ()
 406                     (do-case (t :eax :labels (io-read-loop end-io-read-loop not-fixnum))
 407                       (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 408                       (:std)
 409                       (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 410                       (:movl ,(cl:* movitz::+movitz-fixnum-factor+ start) :ecx)
 411                      io-read-loop
 412                       (:cmpl :ecx ,(cl:* movitz::+movitz-fixnum-factor+ end))
 413                       (:jbe 'end-io-read-loop)
 414                       (:addl 4 :ecx)
 415                       (:inl :dx :eax)
 416                       (:movl :eax (:ebx ,(+ offset -4) :ecx))
 417                       (:jmp 'io-read-loop)
 418                      end-io-read-loop
 419                       (:movl :edi :edx)
 420                       (:movl :edi :eax)
 421                       (:cld)
 422                       (:movl :ebx :eax))))))
 423             (:16-bit
 424              (assert (= 4 movitz:+movitz-fixnum-factor+))
 425              (if (and t (<= 1 count 20))
 426                  `(let ((,port-var ,port)
 427                         (,object-var ,object))
 428                     (with-inline-assembly-case ()
 429                       (do-case (t :eax)
 430                         (:std)
 431                         (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 432                         (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 433                         ,@(loop for i from start below end
 434                               appending
 435                                 `((:inw :dx :ax)
 436                                   (:movw :ax (:ebx ,(+ offset (* 2 i))))))
 437                         (:movl :edi :edx)
 438                         (:movl :ebx :eax)
 439                         (:cld))))
 440                `(let ((,port-var ,port)
 441                       (,object-var ,object))
 442                   (with-inline-assembly-case ()
 443                     (do-case (t :eax :labels (io-read-loop end-io-read-loop not-fixnum))
 444                       (:std)
 445                       (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 446                       (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 447                       (:movl ,(cl:* 1 start) :ecx)
 448                      io-read-loop
 449                       (:cmpl ,end :ecx)
 450                       (:ja 'end-io-read-loop)
 451                       (:addl 1 :ecx)
 452                       (:inw :dx :ax)
 453                       (:movw :ax (:ebx ,(+ offset -2) (:ecx 2)))
 454                       (:jmp 'io-read-loop)
 455                      end-io-read-loop
 456                       (:movl :edi :edx)
 457                       (:movl :ebx :eax)
 458                       (:cld))))))
 459             (t (error "~S byte-size ~S not implemented." (car form) byte-size)))))
 460        ((and (movitz:movitz-constantp offset env))
 461         (let ((start-var (gensym "start-"))
 462               (end-var (gensym "end-"))
 463               (offset (movitz:movitz-eval offset env)))
 464           (case byte-size
 465             (:8-bit
 466              (assert (= 4 movitz:+movitz-fixnum-factor+))
 467              `(let ((,port-var ,port)
 468                     (,object-var ,object)
 469                     (,start-var ,start)
 470                     (,end-var ,end))
 471                 (with-inline-assembly-case ()
 472                   (do-case (t :eax :labels (io-read-loop not-fixnum zero-length))
 473                     (:std)
 474                     (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 475                     (:compile-two-forms (:ecx :eax) ,start-var ,end-var)
 476                     (:subl :ecx :eax)   ; EAX = length
 477                     (:jna 'zero-length)
 478                     (:movl :eax :esi)
 479                     (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 480                     (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
 481                    io-read-loop
 482                     (:inb :dx :al)
 483                     (:addl 1 :ecx)
 484                     (:subl ,movitz:+movitz-fixnum-factor+ :esi)
 485                     (:movb :al (:ebx ,(+ offset -1) (:ecx 1)))
 486                     (:ja 'io-read-loop)
 487                    zero-length
 488                     (:movl :edi :edx)
 489                     (:movl :edi :eax)
 490                     (:cld)
 491                     (:movl :ebx :eax)))))
 492             (:16-bit
 493              (assert (= 4 movitz:+movitz-fixnum-factor+))
 494              `(let ((,port-var ,port)
 495                     (,object-var ,object)
 496                     (,start-var ,start)
 497                     (,end-var ,end))
 498                 (with-inline-assembly-case ()
 499                   (do-case (t :eax :labels (io-read-loop not-fixnum zero-length))
 500                     (:std)              ; only EBX is GC root now
 501                     (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 502                     (:compile-two-forms (:ecx :eax) ,start-var ,end-var)
 503                     (:subl :ecx :eax)
 504                     (:jna 'zero-length)
 505                     (:movl :eax :esi)   ; ESI = length
 506                     (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 507                     (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
 508                    io-read-loop
 509                     (:inw :dx :ax)
 510                     (:addl 2 :ecx)
 511                     (:movw :ax (:ebx ,(+ offset -2) (:ecx 1)))
 512                     (:subl ,(* 2 movitz:+movitz-fixnum-factor+) :esi)
 513                     (:ja 'io-read-loop)
 514                    zero-length
 515                     (:movl :edi :edx)   ; safe value
 516                     (:movl :edi :eax)
 517                     (:cld)
 518                     (:movl :ebx :eax)
 519                     (:movl (:ebp -4) :esi)))))
 520             (:32-bit
 521              (assert (= 4 movitz:+movitz-fixnum-factor+))
 522              `(let ((,port-var ,port)
 523                     (,object-var ,object)
 524                     (,start-var ,start)
 525                     (,end-var ,end))
 526                 (with-inline-assembly-case ()
 527                   (do-case (t :eax :labels (io-read-loop end-io-read-loop not-fixnum))
 528                     (:std)              ; only EBX is GC root now
 529                     (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 530                     (:compile-two-forms (:ecx :eax) ,start-var ,end-var)
 531                     (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 532                     (:pushl :eax)       ; keep end in (:esp)
 533                    io-read-loop
 534                     (:cmpl :ecx (:esp))
 535                     (:jbe 'end-io-read-loop)
 536                     (:inw :dx :ax)
 537                     (:addl 4 :ecx)
 538                     (:movw :ax (:ebx ,(+ offset -4) :ecx))
 539                     (:jmp 'io-read-loop)
 540                    end-io-read-loop
 541                     (:popl :edx)        ; increment :esp, and put a lispval in :edx.
 542                     (:movl :ebx :eax)
 543                     (:cld)))))
 544             (t (error "~S byte-size ~S not implemented." (car form) byte-size)))))
 545        (t (error "Variable offset not implemented."))))))
 546
 547 (defun %io-port-read-succession (port object offset start end byte-size)
 548   (unless (= 2 offset)
 549     (error "Only offset 2 implemented."))
 550   (case byte-size
 551     (:8-bit
 552      (%io-port-read-succession port object 2 start end :8-bit))
 553     (:16-bit
 554      (%io-port-read-succession port object 2 start end :16-bit))
 555     (:32-bit
 556      (%io-port-read-succession port object 2 start end :32-bit))
 557     (t (error "Unknown byte-size ~S." byte-size))))
 558
 559 (define-compiler-macro %io-port-write-succession (&whole form port object offset start end byte-size
 560                                                   &environment env)
 561   (if (not (movitz:movitz-constantp byte-size env))
 562       form
 563     (let ((port-var (gensym "port-var-"))
 564           (object-var (gensym "object-var-"))
 565           (byte-size (movitz:movitz-eval byte-size env)))
 566       (cond
 567        ((and (movitz:movitz-constantp offset env)
 568              (movitz:movitz-constantp start env)
 569              (movitz:movitz-constantp end env))
 570         (let* ((offset (movitz:movitz-eval offset env))
 571                (start (movitz:movitz-eval start env))
 572                (end (movitz:movitz-eval end env))
 573                (count (- end start)))
 574           (check-type count (integer 0 #x10000))
 575           (case byte-size
 576             (:32-bit
 577              (assert (= 4 movitz:+movitz-fixnum-factor+))
 578              (if (<= 1 count 20)
 579                  `(let ((,port-var ,port)
 580                         (,object-var ,object))
 581                     (with-inline-assembly-case ()
 582                       (do-case (t :eax)
 583                         (:std)
 584                         (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 585                         (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 586                         ,@(loop for i from start below end
 587                               appending
 588                                 `((:movl (:ebx ,(+ offset (* 4 i))) :eax)
 589                                   (:outl :eax :dx)))
 590                         (:movl :edi :edx)
 591                         (:movl :ebx :eax)
 592                         (:cld))))
 593                `(let ((,port-var ,port)
 594                       (,object-var ,object))
 595                   (with-inline-assembly-case ()
 596                     (do-case (t :eax :labels (io-read-loop end-io-read-loop not-fixnum))
 597                       (:std)
 598                       (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 599                       (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 600                       (:movl ,(cl:* movitz::+movitz-fixnum-factor+ start) :ecx)
 601                      io-read-loop
 602                       (:cmpl :ecx ,(cl:* movitz::+movitz-fixnum-factor+ end)) ; XXX
 603                       (:jbe 'end-io-read-loop)
 604                       (:addl 4 :ecx)
 605                       (:movl (:ebx ,(+ offset -4) :ecx) :eax)
 606                       (:outl :eax :dx)
 607                       (:jmp 'io-read-loop)
 608                      end-io-read-loop
 609                       (:movl :edi :edx)
 610                       (:movl :ebx :eax)
 611                       (:cld))))))
 612             (t (error "~S byte-size ~S not implemented." (car form) byte-size)))))
 613        ((and (movitz:movitz-constantp offset env))
 614         (let ((start-var (gensym "start-"))
 615               (end-var (gensym "end-"))
 616               (offset (movitz:movitz-eval offset env)))
 617           (case byte-size
 618             (:8-bit
 619              `(let ((,port-var ,port)
 620                     (,object-var ,object)
 621                     (,start-var ,start)
 622                     (,end-var ,end))
 623                 (with-inline-assembly-case ()
 624                   (do-case (t :eax :labels (io-read-loop not-fixnum zero-length))
 625                     (:std)
 626                     (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 627                     (:compile-two-forms (:ecx :eax) ,start-var ,end-var)
 628                     (:subl :ecx :eax)   ; EAX = length
 629                     (:jna 'zero-length)
 630                     (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 631                     (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
 632                     (:pushl :eax)       ; keep end in (:esp)
 633                    io-read-loop
 634                     (:addl 1 :ecx)
 635                     (:subl ,movitz:+movitz-fixnum-factor+ (:esp))
 636                     (:movb (:ebx ,(+ offset -1) (:ecx 1)) :al)
 637                     (:outb :al :dx)
 638                     (:jnz 'io-read-loop)
 639                     (:popl :edx)        ; increment :esp, and put a lispval in :edx.
 640                    zero-length
 641                     (:movl :ebx :eax)
 642                     (:cld)))))
 643             (:16-bit
 644              `(let ((,port-var ,port)
 645                     (,object-var ,object)
 646                     (,start-var ,start)
 647                     (,end-var ,end))
 648                 (with-inline-assembly-case ()
 649                   (do-case (t :eax :labels (io-read-loop not-fixnum zero-length))
 650                     (:std)
 651                     (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 652                     (:compile-two-forms (:ecx :eax) ,start-var ,end-var)
 653                     (:subl :ecx :eax)
 654                     (:jna 'zero-length)
 655                     (:movl :eax :esi)   ; ESI = length
 656                     (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 657                     (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
 658                    io-read-loop
 659                     (:addl 2 :ecx)
 660                     (:movw (:ebx ,(+ offset -2) (:ecx 1)) :ax)
 661                     (:outw :ax :dx)
 662                     (:subl ,(* 2 movitz:+movitz-fixnum-factor+) :esi)
 663                     (:ja 'io-read-loop)
 664                    zero-length
 665                     (:movl :edi :edx)
 666                     (:movl :edi :eax)
 667                     (:cld)
 668                     (:movl :ebx :eax)
 669                     (:movl (:ebp -4) :esi)))))
 670             (:32-bit
 671              (assert (= 4 movitz:+movitz-fixnum-factor+))
 672              `(let ((,port-var ,port)
 673                     (,object-var ,object)
 674                     (,start-var ,start)
 675                     (,end-var ,end))
 676                 (with-inline-assembly-case ()
 677                   (do-case (t :eax :labels (io-read-loop not-fixnum end-io-read-loop))
 678                     (:std)
 679                     (:compile-two-forms (:edx :ebx) ,port-var ,object-var)
 680                     (:compile-two-forms (:ecx :eax) ,start-var ,end-var)
 681                     (:shrl ,movitz::+movitz-fixnum-shift+ :edx)
 682                     (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
 683                     (:pushl :eax)       ; keep end in (:esp)
 684                    io-read-loop
 685                     (:cmpl :ecx (:esp))
 686                     (:jbe 'end-io-read-loop)
 687                     (:addl 4 :ecx)
 688                     (:movl (:ebx ,(+ offset -4) (:ecx 1)) :eax)
 689                     (:outl :eax :dx)
 690                     (:jmp 'io-read-loop)
 691                    end-io-read-loop
 692                     (:popl :edx)        ; increment :esp, and put a lispval in :edx.
 693                     (:movl :ebx :eax)
 694                     (:cld)))))
 695             (t (error "~S byte-size ~S not implemented." (car form) byte-size)))))
 696        (t (error "Variable offset not implemented."))))))
 697
 698 (defun %io-port-write-succession (port object offset start end byte-size)
 699   (unless (= 2 offset)
 700     (error "Only offset 2 implemented."))
 701   (case byte-size
 702     (:8-bit
 703      (%io-port-write-succession port object 2 start end :8-bit))
 704     (:16-bit
 705      (%io-port-write-succession port object 2 start end :16-bit))
 706     (:32-bit
 707      (%io-port-write-succession port object 2 start end :32-bit))
 708     (t (error "Unknown byte-size ~S." byte-size))))
 709