Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv10011

Modified Files: harddisk.lisp Log Message: Checked in new version from Peter Minten.

Date: Wed May 5 04:26:14 2004 Author: ffjeld

Index: movitz/losp/tmp/harddisk.lisp diff -u movitz/losp/tmp/harddisk.lisp:1.2 movitz/losp/tmp/harddisk.lisp:1.3 --- movitz/losp/tmp/harddisk.lisp:1.2 Sat Apr 24 11:13:26 2004 +++ movitz/losp/tmp/harddisk.lisp Wed May 5 04:26:14 2004 @@ -1,264 +1,318 @@ -;;;; $Id: harddisk.lisp,v 1.2 2004/04/24 15:13:26 ffjeld Exp $ - -(require :lib/named-integers) -(provide :tmp/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.harddisk) - -;;; -;;; global variables -;;; -(defvar *hd-controllers* (vector (make-instance 'hd-controller)) - "A vector of harddisk controllers.") - -;;; -;;; constants -;;; -(defconstant +hd-default-first-irq+ 14) -(defconstant +hd-default-second-irq+ 15) -(defconstant +hd-default-first-command-base+ #x1F0) -(defconstant +hd-default-second-command-base+ #x170) -(defconstant +hd-default-first-control-base+ #x3F6) -(defconstant +hd-default-second-control-base+ #x376) - -(define-named-integer hd-register-offset - (:only-constants t) - (0 data) - (1 error) - (1 features) - (2 sector-count) - (3 lba-byte-1) ;bits 0-7 - (4 lba-byte-2) ;bits 8-15 - (5 lba-byte-3) ;bits 16-23 - (6 lba-byte-4) ;bits 24-27 - (7 status) - (7 command)) - -(define-named-integer hd-commands - (:only-constants t) - (#x20 read-sectors-with-retry) - (#x30 write-sectors-with-retry)) - -(define-named-integer hd-status-bits - (:only-constants t) - (0 error) - (1 index) - (2 corrected-data) - (3 data-request) - (4 drive-seek-complete) - (5 drive-write-fault) - (6 drive-ready) - (7 busy)) - -;;; -;;; 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))) - -(defun hd-controller-feed-drive (hdc drive) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - (logior (* #b00010000 drive) - (logand (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - #b11101111)))) - -(defun hd-controller-feed-lba-address (hdc lba) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-1) - :unsigned-byte8) - (logand lba #x000000FF)) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-2) - :unsigned-byte8) - (logand lba #x0000FF00)) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-3) - :unsigned-byte8) - (logand lba #x00FF0000)) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-3) - :unsigned-byte8) - (logior (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - (logand lba #x000F0000)))) - -;;; -;;; 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-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 +;;;; $Id: harddisk.lisp,v 1.3 2004/05/05 08:26:14 ffjeld Exp $ + +(require :lib/named-integers) + +(provide :tmp/harddisk) + +(defpackage muerte.x86-pc.harddisk + (:use muerte.cl muerte muerte.lib muerte.x86-pc) + (:export hdc-reset + hd-read-sectors + hd-write-sectors)) + +(in-package muerte.x86-pc.harddisk) + +;;; +;;; global variables +;;; +(defvar *hd-controllers* (vector (make-instance 'hd-controller)) + "A vector of harddisk controllers.") + +;;; +;;; constants +;;; +(defconstant +hd-default-first-irq+ 14) +(defconstant +hd-default-second-irq+ 15) +(defconstant +hd-default-first-command-base+ #x1F0) +(defconstant +hd-default-second-command-base+ #x170) +(defconstant +hd-default-first-control-base+ #x3F6) +(defconstant +hd-default-second-control-base+ #x376) + +;;; +;;; 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))) +;;; +;;; accessors +;;; + +(defmacro data-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 0) :unsigned-byte16)) + +(defmacro features-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 1) :unsigned-byte8)) + +(defmacro error-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 1) :unsigned-byte8)) + +(defmacro sector-count-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 2) :unsigned-byte8)) + +(defmacro lba-low-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 3) :unsigned-byte8)) + +(defmacro lba-mid-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 4) :unsigned-byte8)) + +(defmacro lba-high-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 5) :unsigned-byte8)) + +(defmacro device-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 6) :unsigned-byte8)) + +(defmacro command-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 7) :unsigned-byte8)) + +(defmacro status-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 7) :unsigned-byte8)) + +(defmacro alt-status-register (hdc) + `(io-port (slot-value ,hdc 'control-base) :unsigned-byte8)) + +;;; +;;; getters +;;; +(defun reg-bsy (hdc) + (get-bit 7 (status-register hdc))) + +(defun reg-drdy (hdc) + (get-bit 6 (status-register hdc))) + +(defun reg-drq (hdc) + (get-bit 3 (status-register hdc))) + +(defun reg-err (hdc) + (get-bit 0 (status-register hdc))) + +(defun reg-alt-bsy (hdc) + (get-bit 7 (alt-status-register hdc))) + +(defun reg-alt-drdy (hdc) + (get-bit 6 (alt-status-register hdc))) + +(defun reg-alt-drq (hdc) + (get-bit 3 (alt-status-register hdc))) + +(defun reg-alt-err (hdc) + (get-bit 3 (alt-status-register hdc))) + +;;; +;;; setters +;;; +(defun set-drive-number (hdc drive) + (set-bit 4 (/= drive 0) (device-register hdc))) + +(defun set-intrq-mode (hdc mode) + (set-bit 1 (not mode) (device-register hdc))) + +(defun set-lba-mode (hdc mode) + (set-bit 6 mode (device-register hdc))) + +(defun set-lba-address (hdc lba) + (setf (lba-low-register hdc) (ldb (byte 8 0) lba)) + (setf (lba-mid-register hdc) (ldb (byte 8 8) lba)) + (setf (lba-high-register hdc) (ldb (byte 8 16) lba)) + (setf (device-register hdc) (dpb (ash (ldb (byte 4 24) lba) -24) + (byte 4 0) + (device-register hdc)))) + +(defun set-sector-count (hdc count) + (setf (sector-count-register hdc) count)) + +(defun set-command (hdc command) + (let ((command-code (case command + ('read-sectors-with-retry #x20) + ('write-sectors-with-retry #x30) + ('identify-drive #xCE)))) + (setf (command-register hdc) command-code))) + +;;; +;;; misc +;;; +(defun get-bit (number place) + (/= 0 (ldb (byte 1 number) place))) + +(defmacro set-bit (number value place) + (let ((gs-number (gensym "number-"))) + `(if ,value + (let ((,gs-number ,number)) + (setf ,place (dpb (ash 1 ,gs-number) (byte 1 ,gs-number) ,place))) + (setf ,place (dpb 0 (byte 1 ,number) ,place))))) + +(defmacro while (test &body body) + `(do () ((not ,test)) + ,@body)) + +(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* (truncate ,hd-number 2))) + (,drive-number (mod ,gs-hdnr 2))) + ,@body))) + +(defun error-code-meaning (code) + (if (< 0 code 257) + (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")) + "No error")) + +(defun hdc-error (hdc command-name hdnr) + (puts "In HDC error") + (error "Harddrive command ~A returned error. HD number: ~A. Error message: '~A'." + command-name hdnr + (error-code-meaning + (io-port (error-register hdc) :unsigned-byte8)))) + +(defun puts (s) + (fresh-line) + (format t s) + (terpri)) + +;;; +;;; hd operations +;;; +(defun hdc-reset (hdcnr) + "Reset the harddisk controller. Must be done at startup to +initialize the harddisk controller." + ;; set SRST + ;; wait > 2ms + ;; continue when BSY=0 + (let ((hdc (aref *hd-controllers* hdcnr))) + (setf (device-register hdc) #x04) + (loop for x from 1 to 2500) + (loop while (reg-bsy hdc)))) + +(defun hd-read-sectors (hdnr start-sector count) + (let ((data (make-array (* count 512) :element-type :unsigned-byte8)) + (offset 0) + input) + (with-hd-info (hdc drive) hdnr + (tagbody +; (puts "in entry") + ;; drive must be ready + ;; drive number must be set + ;; intrq's must not be used + ;; LBA mode must be on + ;; LBA must be set + ;; sector-count must be set + ;; command must be entered + ;; 400 nsec must be waited before checking BSY + (loop until (reg-drdy hdc)) + (loop while (reg-alt-bsy hdc)) + (set-drive-number hdc drive) + (set-intrq-mode hdc nil) + (set-lba-mode hdc t) + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'read-sectors-with-retry) + (dotimes (x 500)) ;aught to be enough waiting + (go :check-status) + ;;;;;;;;;;;;;;;;;; + :check-status +; (puts "in check-status") + ;; if BSY=0 and DRQ=0 then error + ;; if BSY=0 and DRQ=1 then go transfer-data + ;; if BSY=1 then go check-state + (let ((status (status-register hdc))) + (if (get-bit 7 status) ;if BSY = 1 + (go :check-status) + (if (get-bit 3 status) ;if DRQ = 1 + (go :transfer-data) + (progn + (hdc-error hdc "read-sectors" hdnr))))) + ;;;;;;;;;;;;;;;;;; + :transfer-data +; (puts "in transfer-data") + ;; read the data register + (setf input (data-register hdc)) + (setf (aref data offset) (ldb (byte 8 0) input)) + (incf offset) + (setf (aref data offset) (ldb (byte 8 8) input)) + (incf offset) + ;; read the status register to determine if we're done + (if (reg-drq hdc) + (if (/= 0 (mod offset 512)) + (go :transfer-data) ;data block not completely transfered + (progn + (alt-status-register hdc) ;read and ignore + (go :check-status))) + (return-from hd-read-sectors data)))))) + +(defun hd-write-sectors (hdnr start-sector data) + (check-type hdnr (integer 0 *)) + (check-type start-sector (integer 0 *)) + (check-type data vector) + (let ((count (truncate (length data) 512)) + (offset 0)) + (with-hd-info (hdc drive) hdnr + (tagbody +; (puts "in entry") + ;; drive must be ready + ;; drive number must be set + ;; intrq's must not be used + ;; LBA mode must be on + ;; LBA must be set + ;; sector-count must be set + ;; command must be entered + ;; 400 nsec must be waited before checking BSY + (loop until (reg-drdy hdc)) + (loop while (reg-alt-bsy hdc)) + (set-drive-number hdc drive) + (set-intrq-mode hdc nil) + (set-lba-mode hdc t) + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'write-sectors-with-retry) + (dotimes (x 500)) ;aught to be enough waiting + (go :check-status) + ;;;;;;;;;;;;;;;;;; + :check-status +; (puts "in check-status") + ;; if BSY=0 and DRQ=0 then error + ;; if BSY=0 and DRQ=1 then go transfer-data + ;; if BSY=1 then go + (let ((status (status-register hdc))) + (if (get-bit 7 status) ;if BSY = 1 + (go :check-status) + (if (get-bit 3 status) ;if DRQ = 1 + (go :transfer-data) + (hdc-error hdc "write-sectors" hdnr)))) + ;;;;;;;;;;;;;;;;;; + :transfer-data +; (puts "in transfer-data") + ;; read the data register + (setf (data-register hdc) (+ (aref data offset) + (ash (aref data (1+ offset)) 8))) + (incf offset 2) + ;; read the status register to determine if we're done + (if (reg-drq hdc) + (if (/= 0 (mod offset 512)) + (go :transfer-data) ;data block not completely transfered + (progn + (alt-status-register hdc) ;read and ignore + (go :check-status))) + (return-from hd-write-sectors nil))))))