Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv21555
Modified Files: harddisk.lisp Log Message: Checked in new version from Peter Minten.
Date: Sat Apr 24 11:13:27 2004 Author: ffjeld
Index: movitz/losp/tmp/harddisk.lisp diff -u movitz/losp/tmp/harddisk.lisp:1.1 movitz/losp/tmp/harddisk.lisp:1.2 --- movitz/losp/tmp/harddisk.lisp:1.1 Mon Apr 19 18:55:55 2004 +++ movitz/losp/tmp/harddisk.lisp Sat Apr 24 11:13:26 2004 @@ -1,10 +1,23 @@ -;;;; $Id: harddisk.lisp,v 1.1 2004/04/19 22:55:55 ffjeld Exp $ +;;;; $Id: harddisk.lisp,v 1.2 2004/04/24 15:13:26 ffjeld Exp $
(require :lib/named-integers) +(provide :tmp/harddisk)
-(provide :x86-pc/harddisk) +(defpackage muerte.x86-pc.harddisk + (:use muerte.cl muerte muerte.lib muerte.x86-pc) + (:export make-512-vector + hd-read-sectors + hd-write-sectors + hd-commands + ))
-(in-package muerte.x86-pc) +(in-package muerte.x86-pc.harddisk) + +;;; +;;; global variables +;;; +(defvar *hd-controllers* (vector (make-instance 'hd-controller)) + "A vector of harddisk controllers.")
;;; ;;; constants @@ -16,53 +29,8 @@ (defconstant +hd-default-first-control-base+ #x3F6) (defconstant +hd-default-second-control-base+ #x376)
-;;; -;;; structures -;;; - -(defstruct hd-controller - (number 0 :type integer) ;for error messages - (command-base +hd-default-first-command-base+ :type (integer 0 *)) - (control-base +hd-default-first-control-base+ :type (integer 0 *)) - (active-hd 0 :type hd) ;hd with pending task - (master nil :type hd) - (slave nil :type hd)) - -(defstruct hd - ;; hd info - (place 0 :type bit) ;0=master,1=slave - (cylinders 0 :type (integer 0 *)) - (heads 0 :type (integer 0 *)) - (spt 0 :type (integer 0 *)) - (sector-1-lba 0 :type (integer 0 *)) - ;; task stuff - (tasks (make-hash-table) :type hash-table) - (pending-tasks '() :type list) - (pending-last-cons '() :type cons) ;speeds append up - (active-task nil :type hd-task) - (done-tasks '() :type list)) - -(deftype hd-data-vector () - '(vector (unsigned-byte 8))) - -(defstruct hd-read-sectors-task - (start-sector 0 :type (unsigned-byte 28)) - (count 1 :type (integer 1 256)) - (data #() :type data-vector) - (offset 0 :type (integer 0 *))) - -(defstruct hd-write-sectors-task - (start-sector 0 :type (unsigned-byte 28)) - (count 1 :type (integer 1 256)) - (data #() :type data-vector) - (offset 0 :type (integer 0 *))) - -;;; -;;; low level code -;;; - (define-named-integer hd-register-offset - (:only-constants t :export-constants t) + (:only-constants t) (0 data) (1 error) (1 features) @@ -75,16 +43,12 @@ (7 command))
(define-named-integer hd-commands - (:only-constants t :export-constants t) + (:only-constants t) (#x20 read-sectors-with-retry) (#x30 write-sectors-with-retry))
-(defun hd-controller-command-register (hdc name type) - (+ (named-integer 'hd-register-offset name) - (hd-controller-command-base hdc))) - (define-named-integer hd-status-bits - (:only-constants t :export-constants t) + (:only-constants t) (0 error) (1 index) (2 corrected-data) @@ -94,130 +58,49 @@ (6 drive-ready) (7 busy))
-(defun hd-controller-busy (hdc) - ;; use control base, not command base, to avoid side effects - (/= 0 (logand (io-port (hd-controller-control-base hdc) - :unsigned-byte8) - #x80))) - -(defun hd-controller-wait-for-ready (hdc) ;wait for BSY=0 - (do () ((not (hd-controller-busy))) ())) - -(defun hd-controller-status (hdc code) - (named-integer 'hd-status-bits code)) - -(defmacro define-hd-controller-interrupt-handler (hdc irq) - (let ((name (gensym "hdc-irq-handler-"))) - `(progn - (defun ,name (number int-frame) - (declare (ignore (number int-frame))) - (let ((hdc ,hdc)) - (if (hd-controller-handle-task-signal hdc) - (hd-controller-queue-next-task hdc)))) - (setf (interrupt-handler ,irq) ,name)))) - -(defgeneric hd-controller-handle-task-signal (hdc task)) - -(defmethod hd-controller-handle-task-signal :before (hdc task) - (hd-controller-wait-for-ready hdc)) ;just in case - -(defmethod hd-controller-handle-task-signal (hdc (task hd-read-sectors-task)) - (with-slots (count data offset) task - (let ((status (io-port (hd-controller-command-register hdc 'status) - :unsigned-byte8)) - (read-data (io-port (hd-controller-command-register hdc 'status) - :unsigned-byte16))) - ;; by now the drive is getting the next piece, if necessary, - ;; so I hope this code is reentrant - (if (= 0 (logand (power 2 (hd-controller-status 'error)) - status)) - (progn - ;; read 512 bytes - (dotimes (i 256) - (setf (aref data offset) (logand read-data #xFF)) - (setf (aref data (1+ offset)) (logand read-data #xFF00)) - (incf offset 2)) - (= offset (1- (* count 512)))) ;return value, are we done or not? - (error "Harddrive read-sectors returned error. Controller nr ~A, HD number: -~A, error register: ~A." - (hd-controller-number hdc) - (hd-controller-active-hd hdc) - (io-port (hd-controller-command-register hdc 'error) - :unsigned-byte8)))))) - -(defmethod hd-controller-handle-task-signal (hdc (task hd-write-sectors-task)) - (with-slots (count data offset) task - (let ((status (io-port (hd-controller-command-register hdc 'status) - :unsigned-byte8)) - (write-data nil)) - (if (= 0 (logand (power 2 (hd-controller-status 'error)) - status)) - (if (= 0 (logand (power 2 (hd-controller-status 'data-request)) - status)) - ;; write 512 bytes - (progn - (dotimes (i 256) - ;; hope the byte order is correct - (setf write-data (aref data offset)) - (incf write-data (* #xFF (aref data (1+ offset)))) - (incf offset 2) - (setf (io-port (hd-controller-command-register hdc 'data) - :unsigned-byte16) - write-data)) - nil) ;not done yet - t) ;no data requested, so done - (error "Harddrive read-sectors returned error. Controller nr ~A, HD number: -~A, error register: ~A." - (hd-controller-number hdc) - (hd-controller-active-hd hdc) - (io-port (hd-controller-command-register hdc 'error) - :unsigned-byte8)))))) - - -(defmethod hd-controller-feed-task :before (hdc task) - (hd-controller-wait-for-ready hdc) - ;; we always use LBA mode +;;; +;;; classes +;;; +(defclass hd-controller () + ((command-base :initform +hd-default-first-command-base+ + :initarg :command-base + :type integer) + (control-base :initform +hd-default-first-control-base+ + :initarg :command-base + :type integer))) + +;;; +;;; waiters +;;; +(defun hd-controller-wait-for-drive-ready (hdc) ;wait for DRDY=1 + (with-slots (control-base) hdc + (loop until (/= 0 (logand (io-port control-base :unsigned-byte8) + #x40))))) + +(defun hd-controller-wait-for-ready (hdc) ;wait for BSY=0 + (with-slots (control-base) hdc + (loop until (= 0 (logand (io-port control-base :unsigned-byte8) + #x80))))) + +(defun hd-controller-wait-for-data-request (hdc) ;wait for DRQ=1 + (with-slots (control-base) hdc + (loop until (/= 0 (logand (io-port control-base :unsigned-byte8) + #x08))))) + +;;; +;;; feeders +;;; +(defun hd-controller-feed-lba-mode (hdc) (setf (io-port (hd-controller-command-register hdc 'lba-byte-4) :unsigned-byte8) (logior (io-port (hd-controller-command-register hdc 'lba-byte-4) :unsigned-byte8) #b01000000)))
-(defmethod hd-controller-feed-task (hdc (task hd-read-sectors-task)) - (with-slots (drive count start-sector) task - ;; set drive - (hd-controller-feed-drive hdc drive) - ;; set count - (setf (io-port (hd-controller-command-register hdc 'sector-count) - :unsigned-byte8) - count) - ;; set address - (hd-controller-feed-lba-address start-sector) - ;; get going - (setf (io-port (hd-controller-command-register hdc 'command) - :unsigned-byte8) - (named-integer 'hd-commands 'read-sectors-with-retry)))) - -(defmethod hd-controller-feed-task (hdc (task hd-write-sectors-task)) - (with-slots (count start-sector offset data) task - ;; set drive - (hd-controller-feed-drive hdc) - ;; set count - (setf (io-port (hd-controller-command-register hdc 'sector-count) - :unsigned-byte8) - count) - ;; set address - (hd-controller-feed-lba-address start-sector) - ;; get going - (setf (io-port (hd-controller-command-register hdc 'command) - :unsigned-byte8) - (named-integer 'hd-commands 'read-sectors-with-retry)))) - - -(defun hd-controller-feed-drive (hdc) +(defun hd-controller-feed-drive (hdc drive) (setf (io-port (hd-controller-command-register hdc 'lba-byte-4) :unsigned-byte8) - (logior (* #b00010000 (hd-controller-active-hd hdc)) + (logior (* #b00010000 drive) (logand (io-port (hd-controller-command-register hdc 'lba-byte-4) :unsigned-byte8) #b11101111)))) @@ -239,43 +122,143 @@ (logand lba #x000F0000))))
;;; -;;; scheduler code +;;; misc +;;; +(defmacro while (test &body body) + `(do () ((not ,test)) + ,@body)) + +(defun div (a b) + "Floored integer division, the painful way." + (let ((r 0) + (x a)) + (while (>= x 0) + (decf x b) + (incf r)) + (1- r))) + +(defun log2 (n) + (cond ((= n 256) 8) + ((= n 128) 7) + ((= n 64) 6) + ((= n 32) 5) + ((= n 16) 4) + ((= n 8) 3) + ((= n 4) 2) + ((= n 2) 1) + ((= n 1) 0))) + +(defmacro with-hd-info ((hdc drive-number) hd-number &body body) + (let ((gs-hdnr (gensym "hd-number-"))) + `(let* ((,gs-hdnr ,hd-number) + (,hdc (aref *hd-controllers* (div ,hd-number 2))) + (,drive-number (mod ,gs-hdnr 2))) + ,@body))) + +(defun hd-controller-command-register (hdc name) + ;; use a case statement for now, until I learn how to use + ;; named-integer right + (+ (case name + ('data 0) + ('error 1) + ('features 1) + ('sector-count 2) + ('lba-byte-1 3) + ('lba-byte-2 4) + ('lba-byte-3 5) + ('lba-byte-4 6) + ('status 7) + ('command 7) + (else (error "HD command register not found ~A" name))) + (slot-value hdc 'command-base))) + +(defun error-code-meaning (code) + (nth (log2 code) + '("Address Mark Not Found" + "Track 0 Not Found" + "Media Change Requested" + "Aborted Command" + "ID Not Found" + "Media Changed" + "Uncorrectable Data Error" + "Bad Block Detected"))) + + +(defun hd-check-error (hdc command-name hdnr) + "Check and when found signal an error in task." + (when (/= 0 (logand (io-port (slot-value hdc 'control-base) + :unsigned-byte8) + #x01)) + (error "Harddrive command ~A returned error. HD number: ~A. Error message: '~A'." + command-name hdnr + (error-code-meaning + (io-port (hd-controller-command-register hdc 'error) + :unsigned-byte8))))) + +;;; +;;; hd operations ;;; -(defun hd-queue-next-task (hdc) - ;; very dumb scheduler, FIFO and master before slave - (labels ((queue (hd) - (let ((task (first (hd-pending-tasks hd)))) - (setf (hd-active-task hd) task) - (unless (rest (hd-pending-tasks hd)) - (setf (hd-pending-last-cons hd) - (hd-pending-tasks hd))) - (hd-controller-feed-task hdc task)))) - (let ((master (hd-controller-master hdc)) - (slave (hd-controller-slave hdc))) - (cond ((> 0 (length (hd-pending-tasks master))) - (queue master) - (setf (hd-controller-active-hd hdc) 0)) - ((> 0 (length (hd-pending-tasks slave))) - (queue slave) - (setf (hd-controller-active-hd hdc) 1)))))) - - -(defun hd-add-read-sectors-task (hd start-sector count) - "Add a task to read count sectors, starting at start-sector. Count -must be between 1 and 256 inclusive." - (let* ((task (make-hd-read-sectors-task :start-sector start-sector - :count (mod (count 256)))) - - (pending-cons (cons task nil))) - (rplacd (hd-pending-last-cons hd) pending-cons) - (setf (hd-pending-last-cons hd) pending-cons))) - -(defun hd-add-write-sectors-task (hd start-sector count data) - "Add a task to write count sectors of data, starting at -start-sector. Count must be between 1 and 256 inclusive." - (let* ((task (make-hd-read-sectors-task :start-sector start-sector - :count (mod (count 256)) - :data data)) - (pending-cons (cons task nil))) - (rplacd (hd-pending-last-cons hd) pending-cons) - (setf (hd-pending-last-cons hd) pending-cons))) \ No newline at end of file +(defun hd-read-sectors (hdnr start-sector count) + (let ((data (make-array 512 :element-type :unsigned-byte8)) + (offset 0) + (read-data nil)) + (with-hd-info (hdc drive) hdnr + ;; set drive + (hd-controller-feed-drive hdc drive) + ;; set count + (setf (io-port (hd-controller-command-register hdc 'sector-count) + :unsigned-byte8) + count) + ;; set LBA and address + (hd-controller-feed-lba-mode hdc) + (hd-controller-feed-lba-address hdc start-sector) + ;; get going + (setf (io-port (hd-controller-command-register hdc 'command) + :unsigned-byte8) + +hd-commands-read-sectors-with-retry+) + ;; data handling + (while (<= offset (* count 512)) + (hd-controller-wait-for-drive-ready hdc) + (hd-controller-wait-for-ready hdc) + (hd-check-error hdc "read-sectors" hdnr) + (hd-controller-wait-for-data-request hdc) + (dotimes (i 256) + (setf read-data (io-port (hd-controller-command-register hdc 'status) + :unsigned-byte16))) + (setf (aref data offset) (logand read-data #xFF)) + (setf (aref data (1+ offset)) (logand read-data #xFF00)) + (incf offset 2)) + ;; done + data))) + +(defun hd-write-sectors (hdnr start-sector data) + (let ((offset 0) + (write-data nil) + (count (div (length data) 512))) + (with-hd-info (hdc drive) hdnr + ;; set drive + (hd-controller-feed-drive hdc drive) + ;; set count + (setf (io-port (hd-controller-command-register hdc 'sector-count) + :unsigned-byte8) + count) + ;; set LBA and address + (hd-controller-feed-lba-mode hdc) + (hd-controller-feed-lba-address hdc start-sector) + ;; get going + (setf (io-port (hd-controller-command-register hdc 'command) + :unsigned-byte8) + +hd-commands-write-sectors-with-retry+) + ;; data handling + (while (<= offset (* count 512)) + (hd-controller-wait-for-drive-ready hdc) + (hd-controller-wait-for-ready hdc) + (hd-check-error hdc "write-sectors" hdnr) + (hd-controller-wait-for-data-request hdc) + (dotimes (i 256) + (setf write-data (aref data offset)) + (incf write-data (* #xFF (aref data (1+ offset)))) + (setf (io-port (hd-controller-command-register hdc 'data) + :unsigned-byte16) + write-data) + (incf offset 2)))))) \ No newline at end of file