[movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Tue May 11 15:05:30 UTC 2004
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
More information about the Movitz-cvs
mailing list