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

Modified Files: harddisk.lisp Log Message: Updates from Peter Minten.

Date: Tue May 11 11:05:28 2004 Author: ffjeld

Index: movitz/losp/tmp/harddisk.lisp diff -u movitz/losp/tmp/harddisk.lisp:1.3 movitz/losp/tmp/harddisk.lisp:1.4 --- movitz/losp/tmp/harddisk.lisp:1.3 Wed May 5 04:26:14 2004 +++ movitz/losp/tmp/harddisk.lisp Tue May 11 11:05:25 2004 @@ -1,4 +1,4 @@ -;;;; $Id: harddisk.lisp,v 1.3 2004/05/05 08:26:14 ffjeld Exp $ +;;;; $Id: harddisk.lisp,v 1.4 2004/05/11 15:05:25 ffjeld Exp $

(require :lib/named-integers)

@@ -7,6 +7,7 @@ (defpackage muerte.x86-pc.harddisk (:use muerte.cl muerte muerte.lib muerte.x86-pc) (:export hdc-reset + hd-identify-device hd-read-sectors hd-write-sectors))

@@ -118,19 +119,35 @@ (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) + (setf (device-register hdc) (dpb (ldb (byte 4 24) lba) (byte 4 0) (device-register hdc))))

+(defun set-lba-address-ext (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)) + + ;; movitz byte function has a restriction, the location must be <= 30 + ;; therefore this workaround + (setf (lba-low-register hdc) (ldb (byte 8 0) (ash lba -24))) + (setf (lba-mid-register hdc) (ldb (byte 8 8) (ash lba -24))) + (setf (lba-high-register hdc) (ldb (byte 8 16) (ash lba -24)))) + (defun set-sector-count (hdc count) (setf (sector-count-register hdc) count))

+(defun set-sector-count-ext (hdc count) + (setf (sector-count-register hdc) (ldb (byte 8 0) count)) + (setf (sector-count-register hdc) (ldb (byte 8 8) 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))) + (setf (command-register hdc) (case command + ('identify-drive #xEC) + ('read-sectors #x20) + ('read-sectors-ext #x24) + ('write-sectors #x30) + ('write-sectors-ext #x34))))

;;; ;;; misc @@ -139,11 +156,7 @@ (/= 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))))) + `(setf ,place (dpb (if ,value 1 0) (byte 1 ,number) ,place)))

(defmacro while (test &body body) `(do () ((not ,test)) @@ -206,9 +219,57 @@ (loop for x from 1 to 2500) (loop while (reg-bsy hdc))))

+(defun hd-identify-device (hdnr) + "Get device information of hdnr. Returns a (vector 256 (unsigned-byte 16))." + (let ((data (make-array 256 :element-type :unsigned-byte16)) + (offset 0)) + (with-hd-info (hdc drive) hdnr + (tagbody + ;; 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-command hdc 'identify-drive) + (dotimes (x 500)) ;aught to be enough waiting + (go :check-status) + ;;;;;;;;;;;;;;;;;; + :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 "identify-device" hdnr))))) + ;;;;;;;;;;;;;;;;;; + :transfer-data + ;; read the data register + (setf (aref data offset) (data-register hdc)) + (incf offset) + ;; read the status register to determine if we're done + (if (reg-drq hdc) + (if (< offset 256) + (go :transfer-data) ;data block not completely transfered + (go :check-status)) + (return-from hd-identify-device data)))))) + (defun hd-read-sectors (hdnr start-sector count) + "Read count sectors from hdnr, starting at start-sector. Returns a (vector (* count 512) (unsigned-byte 8)). If start-sector doesn't fit into 28 bits or count doesn't fit into 8 bits an attempt is made to use 48 bits addressing." (let ((data (make-array (* count 512) :element-type :unsigned-byte8)) (offset 0) + (ext-mode (or (>= start-sector #xFFFFFFF) + (>= count #xFF))) input) (with-hd-info (hdc drive) hdnr (tagbody @@ -226,9 +287,20 @@ (set-drive-number hdc drive) (set-intrq-mode hdc nil) (set-lba-mode hdc t) + (if ext-mode + (progn + (puts "using 48 bits addressing") + (set-lba-address-ext hdc start-sector) + (set-sector-count-ext hdc count) + (set-command hdc 'read-sectors-ext)) + (progn + (puts "using 28 bits addressing") + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'read-sectors))) (set-lba-address hdc start-sector) (set-sector-count hdc count) - (set-command hdc 'read-sectors-with-retry) + (set-command hdc 'read-sectors) (dotimes (x 500)) ;aught to be enough waiting (go :check-status) ;;;;;;;;;;;;;;;;;; @@ -266,8 +338,10 @@ (check-type hdnr (integer 0 *)) (check-type start-sector (integer 0 *)) (check-type data vector) - (let ((count (truncate (length data) 512)) - (offset 0)) + (let* ((count (truncate (length data) 512)) + (ext-mode (or (>= start-sector #xFFFFFFF) + (>= count #xFF))) + (offset 0)) (with-hd-info (hdc drive) hdnr (tagbody ; (puts "in entry") @@ -284,9 +358,20 @@ (set-drive-number hdc drive) (set-intrq-mode hdc nil) (set-lba-mode hdc t) + (if ext-mode + (progn + (puts "using 48 bits addressing") + (set-lba-address-ext hdc start-sector) + (set-sector-count-ext hdc count) + (set-command hdc 'write-sectors-ext)) + (progn + (puts "using 28 bits addressing") + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'write-sectors))) (set-lba-address hdc start-sector) (set-sector-count hdc count) - (set-command hdc 'write-sectors-with-retry) + (set-command hdc 'write-sectors) (dotimes (x 500)) ;aught to be enough waiting (go :check-status) ;;;;;;;;;;;;;;;;;; @@ -315,4 +400,4 @@ (progn (alt-status-register hdc) ;read and ignore (go :check-status))) - (return-from hd-write-sectors nil)))))) + (return-from hd-write-sectors nil)))))) \ No newline at end of file