February 2004 - movitz-cvs@common-lisp.net

[movitz-cvs] CVS update: movitz/losp/lib/net/arp.lisp
by Frode Vatvedt Fjeld 26 Feb '04

26 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv15462 Modified Files: arp.lisp Log Message: Minor tweaks. Date: Thu Feb 26 06:28:08 2004 Author: ffjeld Index: movitz/losp/lib/net/arp.lisp diff -u movitz/losp/lib/net/arp.lisp:1.3 movitz/losp/lib/net/arp.lisp:1.4 --- movitz/losp/lib/net/arp.lisp:1.3 Mon Jan 19 06:23:45 2004 +++ movitz/losp/lib/net/arp.lisp Thu Feb 26 06:28:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Mar 20 15:01:15 2003 ;;;; -;;;; $Id: arp.lisp,v 1.3 2004/01/19 11:23:45 ffjeld Exp $ +;;;; $Id: arp.lisp,v 1.4 2004/02/26 11:28:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -41,8 +41,9 @@ (hard-type 1) (prot-type #x0800) (hard-size 6) (prot-size 4)) (if packet - (setf (fill-pointer packet) 64) - (setf packet (make-array 64 :element-type 'muerte::u8))) + (setf (fill-pointer packet) (max +min-ethernet-frame-size+ + (+ start 28))) + (setf packet (make-array +min-ethernet-frame-size+ :element-type 'muerte::u8))) (setf (aref packet (+ start 0)) (ldb (byte 8 8) hard-type) (aref packet (+ start 1)) (ldb (byte 8 0) hard-type) (aref packet (+ start 2)) (ldb (byte 8 8) prot-type)

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ip6.lisp
by Frode Vatvedt Fjeld 26 Feb '04

26 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv11037 Modified Files: ip6.lisp Log Message: Comment out some old profiling stuff. Date: Thu Feb 26 06:27:07 2004 Author: ffjeld Index: movitz/losp/lib/net/ip6.lisp diff -u movitz/losp/lib/net/ip6.lisp:1.4 movitz/losp/lib/net/ip6.lisp:1.5 --- movitz/losp/lib/net/ip6.lisp:1.4 Fri Feb 13 17:11:34 2004 +++ movitz/losp/lib/net/ip6.lisp Thu Feb 26 06:27:07 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 14 17:25:31 2001 ;;;; -;;;; $Id: ip6.lisp,v 1.4 2004/02/13 22:11:34 ffjeld Exp $ +;;;; $Id: ip6.lisp,v 1.5 2004/02/26 11:27:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -611,7 +611,7 @@ (unless request (return-from process-request)) (macrolet ((profile-point () - `(vector-push (pit8253-timer-count 0) timings))) + #+ignore `(vector-push (pit8253-timer-count 0) timings))) (profile-point) (when (and (= +ether-type-ip6+ (ether-type request)) (= 6 (packet-version request)) @@ -737,6 +737,7 @@ (t (warn "Unknown IPv6 header type: #x~X" (packet-next-header request)))) (profile-point) + #+ignore (dotimes (i (length timings)) (format t "~D: ~:D~%" i (* 838 (- #x10000 (aref timings i)))))

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp
by Frode Vatvedt Fjeld 26 Feb '04

26 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv6433 Modified Files: ip4.lisp Log Message: Added a "router" argument to ip4-test. Ip4-test will broadcast an ARP request for this address when starting up. The primary purpose of this is to notify the ARP caches of other hosts on the LAN of our presence. There are also some various other tweaks and bits and pieces. Date: Thu Feb 26 06:26:25 2004 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.4 movitz/losp/lib/net/ip4.lisp:1.5 --- movitz/losp/lib/net/ip4.lisp:1.4 Fri Feb 13 17:11:29 2004 +++ movitz/losp/lib/net/ip4.lisp Thu Feb 26 06:26:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.4 2004/02/13 22:11:29 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.5 2004/02/26 11:26:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,6 +22,8 @@ (defpackage muerte.ip4 (:use #:muerte.cl #:muerte #:muerte.ethernet #:muerte.lib) (:export #:pprint-ip4 + #:read-ip4-address + #:ip4-address #:ip4-test #:ip4-free)) @@ -37,6 +39,10 @@ :initarg :address :accessor address))) +(defmethod unknown-packet ((stack ip4-stack) packet) + (declare (ignore packet))) + + (define-named-integer ip-protocol (:export-constants t) (1 icmp) (6 tcp) @@ -98,69 +104,6 @@ (integer-name 'ip-protocol (ip-protocol packet start) nil) packet))))))) -(defvar *ne2000* nil) - -(defun ip4-test (&optional (ip #(129 242 16 173)) - (ethernet *ne2000*)) - (unless ethernet - (setf ethernet - (some #'muerte.x86-pc.ne2k:ne2k-probe - muerte.x86-pc.ne2k:+ne2k-probe-addresses+)) - (assert ethernet ethernet "No ethernet device.") - (when ethernet - (setf (promiscuous-p ethernet) nil - (accept-broadcasts-p ethernet) t) - (setf *ne2000* ethernet))) - (loop with stack = (make-instance 'ip4-stack - :interface ethernet - :address ip) - as key = (muerte.x86-pc.keyboard:poll-char) - do (cond - ((eql #\esc key) (break "You broke ip4!")) - (key (return (values)))) - (let ((packet (muerte.ethernet:receive ethernet))) - (when packet - #+ignore (format t "~&From ~@/ethernet:pprint-mac/ to ~:/ethernet:pprint-mac/ of type ~S.~%" - packet packet (integer-name 'ether-type (ether-type packet) nil)) - (case (ether-type packet) - (#.+ether-type-arp+ (arp-input stack packet 14)) - (#.+ether-type-ip4+ (ip-input stack packet 14)) - (#.+ether-type-mswin-heartbeat+ - (format t "~&MS heartbeat from ~@/ethernet:pprint-mac/: [" packet) - (loop for i from 40 below (length packet) by 2 - do (write-char (code-char (aref packet i)))) - (format t "]~%") - #+ignore - (let ((pos (or (search packet #(129 242 16) :start1 14) - (search packet #(129 242) :start1 14)))) - (if pos - (format t "~&MS heartbeat from ~@/ethernet:pprint-mac/ found possible IP at ~D: ~/ip4:pprint-ip4.~%" - packet pos (subseq packet pos (+ pos 6))) - (progn - (format t "~&MS heartbeat found no IP from ~:@/ethernet:pprint-mac/.~%" - packet) - (loop for y from 0 below (length packet) by 16 - do (format t "~& ") - (loop for x from y below (min (length packet) (+ y 16)) - when (zerop (rem x 4)) - do (format t " ") - do (format t " ~2,'0X" (aref packet x)))) - (fresh-line))))) - (t (cond - ((ether-802.3-snap-p packet) - (format t "~&~:@/ethernet:pprint-mac/ IEEE 802.3 SNAP type ~A len ~D.~%" - packet (integer-name 'ether-type (ether-802.3-snap-type packet) nil) - (length packet))) - ((ether-802.3-p packet) - (format t "~&~:@/ethernet:pprint-mac/ IEEE 802.3 LLC ssap ~S, dsap ~S, type ~D len ~D.~%" - packet - (ether-802.3-llc-ssap packet) - (ether-802.3-llc-dsap packet) - (ether-802.3-llc-type packet) - (length packet))) - (t (format t "~&From ~:@/ethernet:pprint-mac/ unknown ether type ~S." - packet (integer-name 'ether-type (ether-type packet) nil))))))))) - (values)) (defun pprint-ip4 (stream address &optional colon at (start 0 start-p)) @@ -178,18 +121,18 @@ nil) (defun arp-input (stack packet start) - #+ignore - (warn "arp operation: ~S ~S ~S" - (integer-name 'arp-op (arp-operation packet start) nil) - (integer-name 'arp-hard-type (arp-hard-type packet start) nil) - (integer-name 'ether-type (arp-prot-type packet start) nil)) +;;; (warn "arp operation: ~S ~S ~S" +;;; (integer-name 'arp-op (arp-operation packet start) nil) +;;; (integer-name 'arp-hard-type (arp-hard-type packet start) nil) +;;; (integer-name 'ether-type (arp-prot-type packet start) nil)) (case (arp-operation packet start) (#.+arp-op-request+ - (when (and (= +arp-hard-type-ethernet+ - (arp-hard-type packet start)) - (= +ether-type-ip4+ - (arp-prot-type packet start)) - (not (mismatch (address stack) packet :start2 (+ start 24) :end2 (+ start 28)))) + (cond + ((and (= +arp-hard-type-ethernet+ + (arp-hard-type packet start)) + (= +ether-type-ip4+ + (arp-prot-type packet start)) + (not (mismatch (address stack) packet :start2 (+ start 24) :end2 (+ start 28)))) (warn "arp request from ~v/ip4:pprint-ip4/." (+ start 14) packet) (transmit (interface stack) (format-ethernet-packet (format-arp-request nil +arp-op-reply+ @@ -201,9 +144,19 @@ (mac-address (interface stack)) packet muerte.ethernet:+ether-type-arp+ - :destination-start (+ start 8))) - )))) - + :destination-start (+ start 8)))) + (t (unknown-packet stack packet) + #+ignore (warn "ARP request for not me ~/ip4:pprint-ip4/: ~v/ip4:pprint-ip4/." + (address stack) (+ start 24) packet)))) + (#.+arp-op-reply+ + (warn "Received an ARP reply: ~v/ip4:pprint-ip4/ is ~v/ethernet:pprint-mac/." + (+ start 14) packet + (+ start 8) packet)) + (t (unknown-packet stack packet) + (warn "Received unknown ARP packet of type ~D~@[ ~A~]" + (arp-operation packet start) + (integer-name 'arp-op (arp-operation packet start) nil))))) + ;;; ICMP @@ -253,7 +206,7 @@ checksum-ok) (cond ((not checksum-ok) - (write-char #\X) + (warn "ICMP checksum failed from ~v@/ip4:pprint-ip4/." ip-start packet) (loop for i upfrom (+ icmp-start 8 8) below (length packet) when (/= (aref packet i) (ldb (byte 8 0) @@ -291,8 +244,7 @@ (+ (ldb (byte 16 0) new-checksum) (ash new-checksum -16)))) (transmit (interface stack) packet) - (write-char #\.) - )))) + (write-char #\.))))) ;;;; UDP @@ -362,8 +314,126 @@ ;;;;; +(defun read-ip4-address (string &optional (start 0)) + (prog (a b c d (i start)) + (multiple-value-setq (a i) + (parse-integer string :start i :junk-allowed t)) + (unless (and (<= 0 a #xff) (char= #\. (char string i))) + (go parse-failure)) + (multiple-value-setq (b i) + (parse-integer string :start (1+ i) :junk-allowed t)) + (unless (and (<= 0 b #xff) (char= #\. (char string i))) + (go parse-failure)) + (multiple-value-setq (c i) + (parse-integer string :start (1+ i) :junk-allowed t)) + (unless (and (<= 0 b #xff) (char= #\. (char string i))) + (go parse-failure)) + (multiple-value-setq (d i) + (parse-integer string :start (1+ i) :junk-allowed t)) + (unless (<= 0 b #xff) + (go parse-failure)) + (let ((x (make-array 4 :element-type '(unsigned-byte 8)))) + (setf (aref x 0) a (aref x 1) b (aref x 2) c (aref x 3) d) + (return x)) + parse-failure + (error "Not an IPv4 address at position ~D in ~S." + i string))) + + +(defun ip4-address (specifier &optional (start 0)) + (or (ignore-errors + (typecase specifier + ((or string symbol) + (read-ip4-address (string specifier) start)) + (vector + (loop with address = (make-array 4 :element-type '(unsigned-byte 8)) + for i from 0 to 3 + as n = (aref specifier (+ start i)) + do (check-type n (unsigned-byte 8)) + (setf (aref address i) n) + finally (return address))))) + (error "Not an IPv4 address: ~S." specifier))) + + + (defun ip4-free () (when *ne2000* (muerte.x86-pc::free-io-space *ne2000*) (setf *ne2000* nil)) + (values)) + +(defvar *ne2000* nil) + +(defun ip4-test (&key (ip #(129 242 16 173)) + (ethernet *ne2000*) + (router #(129 242 16 1))) + (unless ethernet + (setf ethernet + (some #'muerte.x86-pc.ne2k:ne2k-probe + muerte.x86-pc.ne2k:+ne2k-probe-addresses+)) + (assert ethernet ethernet "No ethernet device.") + (when ethernet + (setf (promiscuous-p ethernet) nil + (accept-broadcasts-p ethernet) t) + (setf *ne2000* ethernet))) + (let ((stack (make-instance 'ip4-stack + :interface ethernet + :address (ip4-address ip)))) + (when router + (transmit (interface stack) + (format-ethernet-packet (format-arp-request nil +arp-op-request+ + (address stack) + (mac-address (interface stack)) + (ip4-address router)) + (mac-address (interface stack)) + +broadcast-address+ + +ether-type-arp+))) + (loop + (case (muerte.x86-pc.keyboard:poll-char) + ((nil)) + ((#\esc) (break "You broke ip4!")) + (t (return (values)))) + (let ((packet (and (packet-available-p ethernet) + (receive ethernet)))) + (when packet + #+ignore + (format t "~&From ~@/ethernet:pprint-mac/ to ~:/ethernet:pprint-mac/ of type ~S.~%" + packet packet (integer-name 'ether-type (ether-type packet) nil)) + (case (ether-type packet) + (#.+ether-type-arp+ (arp-input stack packet 14)) + (#.+ether-type-ip4+ (ip-input stack packet 14)) + (#.+ether-type-mswin-heartbeat+ + (format t "~&MS heartbeat from ~@/ethernet:pprint-mac/: [" packet) + (loop for i from 40 below (length packet) by 2 + do (write-char (code-char (aref packet i)))) + (format t "]~%") + (let ((pos (or (search packet #(129 242 16) :start1 14) + (search packet #(129 242) :start1 14)))) + (if pos + (format t "~&MS heartbeat from ~@/ethernet:pprint-mac/ found possible IP at ~D: ~/ip4:pprint-ip4.~%" + packet pos (subseq packet pos (+ pos 6))) + (progn + (format t "~&MS heartbeat found no IP from ~:@/ethernet:pprint-mac/.~%" + packet) + (loop for y from 0 below (length packet) by 16 + do (format t "~& ") + (loop for x from y below (min (length packet) (+ y 16)) + when (zerop (rem x 4)) + do (format t " ") + do (format t " ~2,'0X" (aref packet x)))) + (fresh-line))))) + (t (cond + ((ether-802.3-snap-p packet) + (format t "~&~:@/ethernet:pprint-mac/ IEEE 802.3 SNAP type ~A len ~D.~%" + packet (integer-name 'ether-type (ether-802.3-snap-type packet) nil) + (length packet))) + ((ether-802.3-p packet) + (format t "~&~:@/ethernet:pprint-mac/ IEEE 802.3 LLC ssap ~S, dsap ~S, type ~D len ~D.~%" + packet + (ether-802.3-llc-ssap packet) + (ether-802.3-llc-dsap packet) + (ether-802.3-llc-type packet) + (length packet))) + (t (format t "~&From ~:@/ethernet:pprint-mac/ unknown ether type ~S." + packet (integer-name 'ether-type (ether-type packet) nil)))))))))) (values))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp
by Frode Vatvedt Fjeld 26 Feb '04

26 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv28225 Modified Files: ne2k.lisp Log Message: Cleaned up this driver code quite a bit, I think it's quite a bit neater now. Date: Thu Feb 26 06:19:25 2004 Author: ffjeld Index: movitz/losp/x86-pc/ne2k.lisp diff -u movitz/losp/x86-pc/ne2k.lisp:1.8 movitz/losp/x86-pc/ne2k.lisp:1.9 --- movitz/losp/x86-pc/ne2k.lisp:1.8 Sun Feb 22 10:19:12 2004 +++ movitz/losp/x86-pc/ne2k.lisp Thu Feb 26 06:19:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 17 15:16:00 2002 ;;;; -;;;; $Id: ne2k.lisp,v 1.8 2004/02/22 15:19:12 ffjeld Exp $ +;;;; $Id: ne2k.lisp,v 1.9 2004/02/26 11:19:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -110,56 +110,55 @@ ;;; Packet IO handling -(defun pop-ringbuffer (device &optional packet (start 0)) +(defun read-from-ne2k-ring (io-base asic-io packet start length ring-start ring-pointer ring-stop) + "Read from a NE2000 ring buffer into packet, starting at start, + length number of bytes." + (check-type packet vector-u8) + (let* ((ring-space (- ring-stop ring-pointer))) + (if (<= length ring-space) + (with-dp8390 (dp8390 io-base) + (with-dp8390-dma (dp8390 remote-read length ring-pointer) + (%io-port-read-succession asic-io packet 2 start (+ start length) :16-bit))) + ;; If the read crosses the ring wrap-around boundary, + ;; that read is factored into two unwrapped reads. + (let ((split-point (+ start ring-space))) + (read-from-ne2k-ring io-base asic-io packet start split-point + ring-start ring-pointer ring-stop) + (read-from-ne2k-ring io-base asic-io packet split-point (- length split-point) + ring-start ring-start ring-stop))))) + +(defun pop-ringbuffer (device packet start) "When the ring-buffer isn't empty, fetch the next packet." (assert (evenp start)) - (unless (ring-empty-p device) - (let ((io-start (truncate start 2)) - (asic-io (asic-io-base device)) - (bnry (cached-bnry device)) - (packet (or packet (make-array +max-ethernet-frame-size+ :element-type 'muerte::u8)))) - (check-type packet vector-u8) - (with-dp8390 (dp8390 (io-base device)) - (multiple-value-bind (packet-status next-bnry packet-length) - (with-dp8390-dma (dp8390 remote-read 4 (* 256 bnry)) - (let ((b (io-port asic-io :unsigned-byte16))) - (values (ldb (byte 8 0) b) - (ldb (byte 8 8) b) - (+ -4 (io-port asic-io :unsigned-byte16))))) - ;; (declare (ignore packet-status)) - (assert (logbitp 0 packet-status) () - "Packet error status #x~X at #x~X, length ~D, next #x~X." - packet-status bnry packet-length next-bnry) - (assert (and (<= (ring-start device) next-bnry) - (< next-bnry (ring-stop device))) () - "Illegal next-bnry #x~X at #x~X, length ~D." - next-bnry bnry packet-length) - (let* ((rx-end (+ start packet-length)) - (io-end (truncate (1+ rx-end)))) - (declare (type (unsigned-byte 16) rx-end)) - (assert (evenp start)) - (setf (fill-pointer packet) rx-end) - (cond - ((< (+ bnry (ash (1- packet-length) -8)) - (ring-stop device)) - (with-dp8390-dma (dp8390 remote-read packet-length (+ (* 256 bnry) 4)) - (%io-port-read-succession asic-io packet 2 io-start io-end :16-bit)) + (let ((read-pointer (next-packet device))) + (when read-pointer + (let ((asic-io (asic-io-base device)) + (packet (or packet (make-array +max-ethernet-frame-size+ :element-type 'muerte::u8))) + (ring-start (ring-start device)) + (ring-stop (ring-stop device))) + (with-dp8390 (dp8390 (io-base device)) + (multiple-value-bind (packet-status next-bnry packet-length) + ;; Read the packet status-and-size header from the ring. + (with-dp8390-dma (dp8390 remote-read 4 read-pointer) + (let ((b (io-port asic-io :unsigned-byte16))) + (values (ldb (byte 8 0) b) + (ldb (byte 8 8) b) + (+ -4 (io-port asic-io :unsigned-byte16))))) + (assert (logbitp 0 packet-status) () + "Packet error status #x~X at #x~X, length ~D, next #x~X." + packet-status read-pointer packet-length next-bnry) + (let ((next-read-pointer (* 256 next-bnry)) + (io-length (if (evenp packet-length) packet-length (1+ packet-length)))) + (assert (and (<= ring-start next-read-pointer) + (< next-read-pointer ring-stop)) () + "Illegal next-bnry #x~X at #x~X, length ~D." + next-read-pointer read-pointer packet-length) + (setf (fill-pointer packet) (+ start packet-length)) + (read-from-ne2k-ring dp8390 asic-io packet start io-length + ring-start (+ 4 read-pointer) ring-stop) (setf (dp8390 ($page0-write bnry)) next-bnry - (cached-bnry device) next-bnry)) - (t (let* ((split-point (+ -4 (ash (- (ring-stop device) bnry) 8))) - (io-split-point (truncate split-point 2))) - (with-dp8390-dma (dp8390 remote-read split-point) - (%io-port-read-succession asic-io packet 2 - io-start (+ io-start io-split-point) :16-bit)) - (with-dp8390-dma (dp8390 remote-read - (- rx-end start split-point) - (* 256 (ring-start device))) - (%io-port-read-succession asic-io packet 2 (+ io-start io-split-point) io-end :16-bit)) - (setf (dp8390 ($page0-write bnry)) next-bnry - (cached-bnry device) next-bnry) - #+ignore (warn "split-point: ~D/~D bnry: ~S" - split-point packet-length bnry)))) - packet)))))) + (read-pointer device) next-read-pointer) + packet))))))) (defun recover-from-ring-overflow (device packet start isr) (with-dp8390 (dp8390 (io-base device)) @@ -194,32 +193,31 @@ (setf (dp8390 ($page0-write cr)) ($command transmit)))))))) (defmethod reset-device ((device ne2000)) - (setf (slot-value device 'transmit-buffer) #x40 - (slot-value device 'ring-start) #x46 - (slot-value device 'ring-stop) #x80 - (slot-value device 'cached-bnry) #x46 - (slot-value device 'cached-curr) #x46) + (setf (slot-value device 'transmit-buffer) #x4000 + (slot-value device 'ring-start) #x4600 + (slot-value device 'ring-stop) #x8000 + (slot-value device 'write-pointer) #x4600 + (slot-value device 'read-pointer) #x4600) (dp8390-initialize device) device) (defmethod packet-available-p ((device ne2000)) - (not (ring-empty-p device))) + (when (next-packet device) + t)) (defmethod transmit ((device ne2000) packet &key (start 0) (end (length packet))) + (check-type packet vector-u8) + (assert (and (evenp start))) (with-dp8390 (dp8390 (io-base device)) - ;; (setf (r8 +page0-write-cr+) +command-page-0+) + (loop while (logbitp ($command-bit transmit) + (dp8390 ($page0-read cr)))) (let ((packet-length (- end start))) - (with-dp8390-dma (dp8390 remote-write packet-length - (ash (transmit-buffer device) 8)) - (%io-port-write-succession (asic-io-base device) packet 2 - (truncate start 2) (truncate (1+ end) 2) :16-bit)) - (loop while (logbitp ($command-bit transmit) (dp8390 ($page0-read cr)))) + (with-dp8390-dma (dp8390 remote-write packet-length (transmit-buffer device)) + (%io-port-write-succession (asic-io-base device) packet 2 start end :16-bit)) (setf (io-register8x2 dp8390 ($page0-write tbcr1) ($page0-write tbcr0)) packet-length (dp8390 ($page0-write cr)) ($command transmit start abort-complete)) (loop while (= (dp8390 ($page0-read cr)) - ($command start transmit abort-complete))) - ;; (loop while (= command (command-value :start t :txp t :rdma :abort-complete))) - )) + ($command start transmit abort-complete))))) nil) (defmethod receive ((device ne2000) &optional packet (start 0))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/dp8390.lisp
by Frode Vatvedt Fjeld 26 Feb '04

26 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv27591 Modified Files: dp8390.lisp Log Message: Cleaned up this driver code quite a bit, I think it's quite a bit neater now. Date: Thu Feb 26 06:19:17 2004 Author: ffjeld Index: movitz/losp/x86-pc/dp8390.lisp diff -u movitz/losp/x86-pc/dp8390.lisp:1.5 movitz/losp/x86-pc/dp8390.lisp:1.6 --- movitz/losp/x86-pc/dp8390.lisp:1.5 Mon Feb 2 09:03:13 2004 +++ movitz/losp/x86-pc/dp8390.lisp Thu Feb 26 06:19:17 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 18 12:21:36 2002 ;;;; -;;;; $Id: dp8390.lisp,v 1.5 2004/02/02 14:03:13 ffjeld Exp $ +;;;; $Id: dp8390.lisp,v 1.6 2004/02/26 11:19:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ (in-package muerte.x86-pc.ne2k) (defconstant +page0-read-map+ - #(cr clda0 clda1 bnry tsr ncr fifo isr crda0 crda1 rsr cntr0 cntr1 cntr2)) + #(cr clda0 clda1 bnry tsr ncr fifo isr crda0 crda1 rbcr0 rbcr1 rsr cntr0 cntr1 cntr2)) (defconstant +page0-write-map+ #(cr pstart pstop bnry tpsr tbcr0 tbcr1 isr rsar0 rsar1 rbcr0 rbcr1 rcr tcr dcr imr)) @@ -109,9 +109,11 @@ (dp8390 ($page0-read isr))) (setf (dp8390 ($page0-write isr)) (ash 1 ($interrupt-status dma-complete))) - (error "Incomplete dp8390~@[ ~A~] @ #x~X DMA: crda=#x~X." + (error "Incomplete dp8390~@[ ~A~] @ #x~X DMA: crda=#x~X~@[, rbcr=#x~X~]." command io-base - (io-register8x2 dp8390 ($page0-read crda1) ($page0-read crda0))))) + (io-register8x2 dp8390 ($page0-read crda1) ($page0-read crda0)) + (let ((x (io-register8x2 dp8390 ($page0-read rbcr1) ($page0-read rbcr0)))) + (unless (= x #xffff) x))))) nil) (defun initialize-dma (io-base command size &optional address) @@ -170,14 +172,14 @@ ((io-base :initarg :io-base :reader io-base) - (cached-curr + (write-pointer ; This is (* 256 CURR) :documentation "This register is written by the device and read by the driver when neccessary." - :initarg :cached-curr - :accessor cached-curr) - (cached-bnry + :initarg :write-pointer + :accessor write-pointer) + (read-pointer ; This is (* 256 BNRY) :documentation "This register is cached on a write-through basis. It's only read by the device." - :initarg :cached-bnry - :accessor cached-bnry) + :initarg :read-pointer + :accessor read-pointer) (transmit-buffer :initarg :transmit-buffer :reader transmit-buffer) @@ -191,17 +193,21 @@ :initform 0 :accessor ring-overflow-count))) -(defun ring-empty-p (device) - "Is the dp8390 receive buffer ring empty?" - (not (or (/= (cached-curr device) ; Can we tell from the cached values alone? - (cached-bnry device)) - (with-dp8390 (dp8390 (io-base device)) - (setf (dp8390 ($page0-write cr)) ($command page-1)) - (let ((new-curr (dp8390 ($page1-read curr)))) ; must update CURR register cache. - (setf (cached-curr device) new-curr) - (setf (dp8390 ($page1-write cr)) ($command page-0)) ; restore page 0 - (/= new-curr (cached-bnry device))))))) - +(defun next-packet (device) + "If there's a packet available in the ring, return its ring pointer address. + Otherwise, return nil." + (let ((read-pointer (read-pointer device))) + (if (/= (write-pointer device) ; Can we tell from the cached values alone? + read-pointer) + read-pointer + (with-dp8390 (dp8390 (io-base device)) + (setf (dp8390 ($page0-write cr)) ($command page-1)) + (let ((new-write-pointer (* 256 (dp8390 ($page1-read curr))))) ; update CURR register cache. + (setf (dp8390 ($page1-write cr)) ($command page-0)) ; restore page 0 + (unless (= new-write-pointer read-pointer) + (setf (write-pointer device) new-write-pointer) + read-pointer)))))) + (defmethod (setf mac-address) :after (mac-address (device dp8390-device)) "Keep the dp8390 device registers in sync with mac-address." (check-type mac-address vector) @@ -258,13 +264,13 @@ (dp8390 ($page0-write rbcr0)) 0 (dp8390 ($page0-write rbcr1)) 0 (dp8390 ($page0-write rcr)) rx-config - (dp8390 ($page0-write tpsr)) (slot-value device 'transmit-buffer) ; address + (dp8390 ($page0-write tpsr)) (truncate (slot-value device 'transmit-buffer) 256) ; address (dp8390 ($page0-write tcr)) ($tx-config loopback-mode-1) ; internal loopback - (dp8390 ($page0-write pstart)) (slot-value device 'ring-start) - (dp8390 ($page0-write bnry)) (slot-value device 'ring-start) - (dp8390 ($page0-write pstop)) (slot-value device 'ring-stop) + (dp8390 ($page0-write pstart)) (truncate (slot-value device 'ring-start) 256) + (dp8390 ($page0-write bnry)) (truncate (slot-value device 'ring-start) 256) + (dp8390 ($page0-write pstop)) (truncate (slot-value device 'ring-stop) 256) (dp8390 ($page0-write cr)) ($command page-1 stop) - (dp8390 ($page1-write curr)) (slot-value device 'ring-start) + (dp8390 ($page1-write curr)) (truncate (slot-value device 'ring-start) 256) (dp8390 ($page1-write cr)) ($command page-0 start) (dp8390 ($page0-write isr)) #xff (dp8390 ($page0-write imr)) interrupt-mask

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp
by Frode Vatvedt Fjeld 26 Feb '04

26 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12032 Modified Files: io-port.lisp Log Message: Fixed %io-port-write-succession for :16-bit. Date: Thu Feb 26 06:18:29 2004 Author: ffjeld Index: movitz/losp/muerte/io-port.lisp diff -u movitz/losp/muerte/io-port.lisp:1.7 movitz/losp/muerte/io-port.lisp:1.8 --- movitz/losp/muerte/io-port.lisp:1.7 Tue Feb 3 05:02:59 2004 +++ movitz/losp/muerte/io-port.lisp Thu Feb 26 06:18:29 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Mar 21 22:14:08 2001 ;;;; -;;;; $Id: io-port.lisp,v 1.7 2004/02/03 10:02:59 ffjeld Exp $ +;;;; $Id: io-port.lisp,v 1.8 2004/02/26 11:18:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -306,8 +306,8 @@ (:cmpl :ecx (:esp)) (:jbe 'end-io-read-loop) (:inw :dx :ax) - (:addl 1 :ecx) - (:movw :ax (:ebx ,(+ offset -2) (:ecx 2))) + (:addl 2 :ecx) + (:movw :ax (:ebx ,(+ offset -2) :ecx)) (:jmp 'io-read-loop) (:popl :eax) ; increment :esp, and put a lispval in :eax. end-io-read-loop))) @@ -439,8 +439,8 @@ io-read-loop (:cmpl :ecx (:esp)) (:jbe 'end-io-read-loop) - (:addl 1 :ecx) - (:movw (:ebx ,(+ offset -2) (:ecx 2)) :ax) + (:addl 2 :ecx) + (:movw (:ebx ,(+ offset -2) :ecx) :ax) (:outw :ax :dx) (:jmp 'io-read-loop) (:popl :eax) ; increment :esp, and put a lispval in :eax.

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 22 Feb '04

22 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3232 Modified Files: compiler.lisp Log Message: Removed a stupid bug in compile-self-evaluating that caused any double-quoted form to be compiled as t. Also, fixed the print-object method for bindings. Date: Sun Feb 22 10:55:04 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.31 movitz/compiler.lisp:1.32 --- movitz/compiler.lisp:1.31 Fri Feb 20 10:08:51 2004 +++ movitz/compiler.lisp Sun Feb 22 10:55:03 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.31 2004/02/20 15:08:51 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.32 2004/02/22 15:55:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2089,7 +2089,8 @@ (binding-name object) (unless (eq object (binding-target object)) (binding-name (binding-target object))) - (when (and (slot-boundp object 'store-type) + (when (and (slot-exists-p object 'store-type) + (slot-boundp object 'store-type) (binding-store-type object)) (apply #'encoded-type-decode (binding-store-type object))))))) @@ -5244,7 +5245,7 @@ (define-compiler compile-self-evaluating (&form form &result-mode result-mode &funobj funobj) "3.1.2.1.3 Self-Evaluating Objects" - (let* ((object (or (quote-form-p form) form)) + (let* ((object form) (movitz-obj (image-read-intern-constant *image* object)) (funobj-env (funobj-env funobj)) (binding (or (cdr (assoc movitz-obj (movitz-environment-bindings funobj-env)))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp
by Frode Vatvedt Fjeld 22 Feb '04

22 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv16024 Modified Files: ne2k.lisp Log Message: Fixed bogus check-type in pop-ringbuffer. Date: Sun Feb 22 10:19:12 2004 Author: ffjeld Index: movitz/losp/x86-pc/ne2k.lisp diff -u movitz/losp/x86-pc/ne2k.lisp:1.7 movitz/losp/x86-pc/ne2k.lisp:1.8 --- movitz/losp/x86-pc/ne2k.lisp:1.7 Mon Feb 2 16:59:27 2004 +++ movitz/losp/x86-pc/ne2k.lisp Sun Feb 22 10:19:12 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 17 15:16:00 2002 ;;;; -;;;; $Id: ne2k.lisp,v 1.7 2004/02/02 21:59:27 ffjeld Exp $ +;;;; $Id: ne2k.lisp,v 1.8 2004/02/22 15:19:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -118,7 +118,7 @@ (asic-io (asic-io-base device)) (bnry (cached-bnry device)) (packet (or packet (make-array +max-ethernet-frame-size+ :element-type 'muerte::u8)))) - (check-type packet 'vector-u8) + (check-type packet vector-u8) (with-dp8390 (dp8390 (io-base device)) (multiple-value-bind (packet-status next-bnry packet-length) (with-dp8390-dma (dp8390 remote-read 4 (* 256 bnry))

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 21 Feb '04

21 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10328 Modified Files: special-operators.lisp Log Message: Added inline-assembly macro :returns-mode. Date: Fri Feb 20 21:04:50 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.14 movitz/special-operators.lisp:1.15 --- movitz/special-operators.lisp:1.14 Tue Feb 17 15:24:06 2004 +++ movitz/special-operators.lisp Fri Feb 20 21:04:50 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.14 2004/02/17 20:24:06 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.15 2004/02/21 02:04:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -460,7 +460,10 @@ &body inline-asm) (cdr case-spec) (when (eq returns :same) - (setf returns result-mode)) + (setf returns + (case result-mode + (:function :multiple-values) + (t result-mode)))) (when (flet ((match (matching-result-mode) (or (eq 'muerte.cl::t matching-result-mode) (eq t matching-result-mode) @@ -518,6 +521,10 @@ (setq side-effects t)) (setf modifies (modifies-union modifies sub-modifies)) sub-code)))) + (setf (assembly-macro-expander :returns-mode amenv) + #'(lambda (expr) + (assert (= 1 (length expr))) + (list returns))) (setf (assembly-macro-expander :result-register amenv) #'(lambda (expr) (assert (= 1 (length expr)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
by Frode Vatvedt Fjeld 20 Feb '04

20 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7297 Modified Files: more-macros.lisp Log Message: New dolist macro. Date: Fri Feb 20 10:38:29 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.2 movitz/losp/muerte/more-macros.lisp:1.3 --- movitz/losp/muerte/more-macros.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/more-macros.lisp Fri Feb 20 10:38:28 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.3 2004/02/20 15:38:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -129,26 +129,15 @@ ,@declarations-and-body))) (defmacro dolist ((var list-form &optional result-form) &body declarations-and-body) - (let ((cons-var (gensym "dolist-cons-var-")) + (let ((cons-var (gensym (format nil "dolist-cons-var-~A-" var))) (loop-tag (gensym "dolist-loop-tag-"))) - (multiple-value-bind (body declarations) - (movitz::parse-declarations-and-body declarations-and-body 'muerte.cl:declare) - `(let ((,cons-var ,list-form) ,var) - (declare ,@declarations) - (block nil - (tagbody - ,loop-tag - (when ,cons-var - (setq ,var (pop ,cons-var)) - ,@body - (go ,loop-tag))) - ,result-form)) - #+ignore - `(do* ((,cons-var ,list-form (cdr ,cons-var)) - (,var (car ,cons-var) (car ,cons-var))) - ((null ,cons-var) ,result-form) - ,@declarations-and-body)))) - + `(prog ((,cons-var ,list-form)) + ,loop-tag + (when ,cons-var + (let ((,var (pop ,cons-var))) + ,@declarations-and-body) + (go ,loop-tag)) + ,(when result-form `(return ,result-form))))) (defmacro letf* (bindings &body body &environment env) "Does what one might expect, saving the old values and setting the generalized

1 0