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

[movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp
by ffjeld＠common-lisp.net 30 Nov '04

30 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv32022 Modified Files: pci.lisp Log Message: Changed pci-far-call a bit. Date: Tue Nov 30 15:16:57 2004 Author: ffjeld Index: movitz/losp/x86-pc/pci.lisp diff -u movitz/losp/x86-pc/pci.lisp:1.7 movitz/losp/x86-pc/pci.lisp:1.8 --- movitz/losp/x86-pc/pci.lisp:1.7 Fri Nov 26 01:02:39 2004 +++ movitz/losp/x86-pc/pci.lisp Tue Nov 30 15:16:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Dec 14 22:33:42 2003 ;;;; -;;;; $Id: pci.lisp,v 1.7 2004/11/26 00:02:39 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.8 2004/11/30 14:16:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -55,7 +55,7 @@ (defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0) (edi 0)) "Make a 'far call' to cs:address with the provided values for eax and ebx. -Returns the values of registers EAX, EBX, ECX, and EDX, and status of CF. +Returns the boolean status of CF, and the values of registers EAX, EBX, ECX, and EDX. The stack discipline is broken during this call, so we disable interrupts in a somewhat feeble attempt to avoid trouble." (check-type address (unsigned-byte 32)) @@ -94,26 +94,27 @@ (:call-segment (:esp)) (:leal (:esp 8) :esp) ; Skip cs:address (:popl :edi) ; First of all, restore EDI! - (:locally (:movl :edi (:edi (:edi-offset values) 8))) + (:locally (:movl :edi (:edi (:edi-offset scratch2)))) (:jnc 'cf=0) (:locally (:pushl (:edi (:edi-offset t-symbol)))) - (:locally (:popl (:edi (:edi-offset values) 8))) + (:locally (:popl (:edi (:edi-offset scratch2)))) cf=0 (:pushl :eax) (:pushl :ebx) (:pushl :edx) (:locally (:movl 3 (:edi (:edi-offset num-values)))) (:call-local-pf box-u32-ecx) ; ECX - (:locally (:movl :eax (:edi (:edi-offset values) 0))) + (:locally (:movl :eax (:edi (:edi-offset values) 4))) (:popl :ecx) ; EDX (:call-local-pf box-u32-ecx) - (:locally (:movl :eax (:edi (:edi-offset values) 4))) + (:locally (:movl :eax (:edi (:edi-offset values) 8))) (:popl :ecx) ; EBX (:call-local-pf box-u32-ecx) - (:locally (:movl :eax (:edi (:edi-offset scratch1)))) + (:locally (:movl :eax (:edi (:edi-offset values) 0))) (:popl :ecx) ; EAX (:call-local-pf box-u32-ecx) - (:locally (:movl (:edi (:edi-offset scratch1)) :ebx)) + (:movl :eax :ebx) + (:locally (:movl (:edi (:edi-offset scratch2)) :eax)) (:movl 5 :ecx) (:movl (:ebp -4) :esi) (:stc) @@ -124,27 +125,28 @@ (defun find-bios32-pci () (let ((bios32-base (find-bios32-base))) (assert bios32-base "No bios32 found.") - (multiple-value-bind (eax ebx ecx edx) + (multiple-value-bind (cf eax ebx ecx edx) (pci-far-call (memref-int bios32-base :offset 4) :eax (pci-word "$PCI")) - (declare (ignore ecx)) + (declare (ignore cf ecx)) (ecase (ldb (byte 8 0) eax) (#x80 (error "The PCI bios32 service isn't present.")) (#x81 (error "The PCI bios32 service doesn't exist.")) (#x00 (+ ebx edx)))))) (defun pci-bios-present () - (multiple-value-bind (eax ebx ecx edx cf) + (multiple-value-bind (cf eax ebx ecx edx) (pci-far-call (find-bios32-pci) :eax #xb101) - (values (pci-string edx) - (ldb (byte 8 8) eax) ; AH: Present status - (ldb (byte 8 0) eax) ; AL: Hardware mechanism - (ldb (byte 8 8) ebx) ; BH: Interface Level Major Version - (ldb (byte 8 0) ebx) ; BL: Interface Level Minor Version - (ldb (byte 8 0) ecx)))) ; CL: Number of last PCI bus in the system + (unless cf + (values (pci-string edx) + (ldb (byte 8 8) eax) ; AH: Present status + (ldb (byte 8 0) eax) ; AL: Hardware mechanism + (ldb (byte 8 8) ebx) ; BH: Interface Level Major Version + (ldb (byte 8 0) ebx) ; BL: Interface Level Minor Version + (ldb (byte 8 0) ecx))))) ; CL: Number of last PCI bus in the system (defun find-pci-device (vendor device &optional (index 0)) - (multiple-value-bind (eax ebx ecx edx cf) + (multiple-value-bind (cf eax ebx) (pci-far-call (find-bios32-pci) :eax #xb102 :ecx device @@ -160,12 +162,11 @@ (#x83 :bad-vendor-id)))))) (defun find-pci-class-code (class-code &optional (index 0)) - (multiple-value-bind (eax ebx ecx edx cf) + (multiple-value-bind (cf eax ebx) (pci-far-call (find-bios32-pci) :eax #xb103 :ecx class-code :esi index) - (declare (ignore ecx edx)) (unless cf (values (ldb (byte 8 8) ebx) ; Bus (ldb (byte 5 3) ebx) ; Device @@ -231,36 +232,59 @@ (nth (ldb (byte 8 0) code) sub-class-table)))) (values (car class-table) sub-class sub-class-if))) -(defun pci-bios-read-configuration-word (bus device function register) - (multiple-value-bind (eax ebx ecx edx cf) +(defun pci-bios-config-space (bus device function register command size) + (multiple-value-bind (cf eax ebx ecx) (pci-far-call (find-bios32-pci) - :eax #xb109 + :eax command :ebx (pci-location bus device function) :edi register) - (declare (ignore ebx edx)) + (declare (ignore ebx)) (unless cf - (values (ldb (byte 16 0) ecx) (pci-return-code eax))))) + (values (ldb (byte size 0) ecx) + (pci-return-code eax))))) -(defun pci-bios-read-configuration-dword (bus device function register) - (multiple-value-bind (eax ebx ecx edx cf) +(defun (setf pci-bios-config-space) (value bus device function register command size) + (declare (ignore size)) + (multiple-value-bind (cf eax) (pci-far-call (find-bios32-pci) - :eax #xb10a + :eax command :ebx (pci-location bus device function) + :ecx value :edi register) - (declare (ignore ebx edx)) (unless cf - (values ecx (pci-return-code eax))))) + (pci-return-code eax)))) + +(defun pci-bios-config-space-dword (bus device function register) + (pci-bios-config-space bus device function register #xb10a 32)) + +(defun pci-bios-config-space-word (bus device function register) + (pci-bios-config-space bus device function register #xb109 16)) + +(defun pci-bios-config-space-byte (bus device function register) + (pci-bios-config-space bus device function register #xb108 8)) + +(defun (setf pci-bios-config-space-dword) (value bus device function register) + (setf (pci-bios-config-space bus device function register #xb10d 32) + value)) + +(defun (setf pci-bios-config-space-word) (value bus device function register) + (setf (pci-bios-config-space bus device function register #xb10c 16) + value)) + +(defun (setf pci-bios-config-space-byte) (value bus device function register) + (setf (pci-bios-config-space bus device function register #xb10b 8) + value)) (defun scan-pci-bus (bus) (loop for device from 0 to 31 do (multiple-value-bind (vendor-id return-code) - (pci-bios-read-configuration-word bus device 0 0) + (pci-bios-config-space-word bus device 0 0) (when (and vendor-id (not (= vendor-id #xffff)) (eq :successful return-code)) - (let ((device-id (pci-bios-read-configuration-word bus device 0 2)) - (status (pci-bios-read-configuration-word bus device 0 6)) - (class-rev (pci-bios-read-configuration-dword bus device 0 8))) + (let ((device-id (pci-bios-config-space-word bus device 0 2)) + (status (pci-bios-config-space-word bus device 0 6)) + (class-rev (pci-bios-config-space-dword bus device 0 8))) (format *query-io* "~&~D: Vendor #x~X, ID #x~X, Class #x~X, Rev. ~D, Status #x~X.~%" device vendor-id device-id

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp
by ffjeld＠common-lisp.net 30 Nov '04

30 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv31991 Modified Files: ne2k.lisp Log Message: This makes Qemu work. Date: Tue Nov 30 15:16:40 2004 Author: ffjeld Index: movitz/losp/x86-pc/ne2k.lisp diff -u movitz/losp/x86-pc/ne2k.lisp:1.13 movitz/losp/x86-pc/ne2k.lisp:1.14 --- movitz/losp/x86-pc/ne2k.lisp:1.13 Wed Nov 24 17:20:30 2004 +++ movitz/losp/x86-pc/ne2k.lisp Tue Nov 30 15:16:38 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.13 2004/11/24 16:20:30 ffjeld Exp $ +;;;; $Id: ne2k.lisp,v 1.14 2004/11/30 14:16:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -217,6 +217,7 @@ (%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)) + #+ignore (loop while (= (dp8390 ($page0-read cr)) ($command start transmit abort-complete))))) nil)

1 0

[movitz-cvs] CVS update: movitz/movitz-mode.el
by ffjeld＠common-lisp.net 30 Nov '04

30 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31954 Modified Files: movitz-mode.el Log Message: *** empty log message *** Date: Tue Nov 30 15:16:18 2004 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.7 movitz/movitz-mode.el:1.8 --- movitz/movitz-mode.el:1.7 Tue Jun 8 00:10:54 2004 +++ movitz/movitz-mode.el Tue Nov 30 15:16:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.7 2004/06/07 22:10:54 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.8 2004/11/30 14:16:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -101,15 +101,19 @@ (fi:eval-in-lisp "(movitz::dump-image)") ;;; (with-current-buffer "*common-lisp*" ;;; (fi:inferior-lisp-newline)) - (if dont-run-bochs-p - (message "Dumping Movitz image...done. Bootblock ID: %d." - (fi:eval-in-lisp "movitz::*bootblock-build*")) - (message "Dumping Movitz image...done. Bootblock ID: %d. Running bochs on \"%s\"..." - (fi:eval-in-lisp "movitz::*bootblock-build*") - display-shortcut) + (cond + (dont-run-bochs-p + (message "Dumping Movitz image...done. Bootblock ID: %d. Running qemu.." + (fi:eval-in-lisp "movitz::*bootblock-build*")) (call-process "/bin/sh" nil 0 nil "-c" - (format "DISPLAY=\"%s\" cd ~/clnet/movitz && ~/tmp/bochs-cvs/bochs -nocp > bochs-parameters" - display-shortcut)))) + (format "DISPLAY=\"%s\" cd ~/clnet/movitz && qemu -fda los0-image -boot a" + display-shortcut))) + (t (message "Dumping Movitz image...done. Bootblock ID: %d. Running bochs on \"%s\"..." + (fi:eval-in-lisp "movitz::*bootblock-build*") + display-shortcut) + (call-process "/bin/sh" nil 0 nil "-c" + (format "DISPLAY=\"%s\" cd ~/clnet/movitz && ~/tmp/bochs-cvs/bochs -nocp > bochs-parameters" + display-shortcut))))) (defun movitz-compile-file () (interactive)

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by Frode Vatvedt Fjeld 26 Nov '04

26 Nov '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv21056 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Fri Nov 26 16:00:14 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.32 movitz/losp/los0.lisp:1.33 --- movitz/losp/los0.lisp:1.32 Wed Nov 24 17:24:16 2004 +++ movitz/losp/los0.lisp Fri Nov 26 15:59:59 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.32 2004/11/24 16:24:16 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.33 2004/11/26 14:59:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1200,15 +1200,15 @@ (error "Double interrupt."))) #+ignore (dolist (range muerte::%memory-map-roots%) - (map-heap-words (lambda (x type) - (declare (ignore type)) + (map-header-vals (lambda (x type) + (declare (ignore type)) + x) + (car range) (cdr range))) + (map-stack-vector (lambda (x foo) + (declare (ignore foo)) x) - (car range) (cdr range))) - (map-stack-words (lambda (x foo) - (declare (ignore foo)) - x) - nil - (current-stack-frame)) + nil + (current-stack-frame)) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) @@ -1305,7 +1305,7 @@ (idt-init) #+ignore (install-los0-consing :kb-size 500) - (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 1024 2048) 2)))) + (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 2048) 2)))) (setf *debugger-function* #'los0-debugger) (clos-bootstrap)

1 0

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

26 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21019 Modified Files: scavenge.lisp Log Message: Renamed the scavenging operators to map-header-vals and map-stack-vector. Added map-lisp-vals. Date: Fri Nov 26 15:59:36 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.35 movitz/losp/muerte/scavenge.lisp:1.36 --- movitz/losp/muerte/scavenge.lisp:1.35 Tue Nov 23 17:09:17 2004 +++ movitz/losp/muerte/scavenge.lisp Fri Nov 26 15:59:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.35 2004/11/23 16:09:17 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.36 2004/11/26 14:59:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -29,9 +29,18 @@ (defvar *scan*) ; debugging (defvar *scan-last*) ; debugging -(defvar *map-heap-words-verbose* nil) +(defvar *map-header-vals-verbose* nil) -(defun map-heap-words (function start-location end-location) +(defun map-lisp-vals (function start-location end-location) + (with-funcallable (do-map function) + (loop for location from start-location below end-location + as object = (memref location 0) + do (when (typep object 'pointer) + (let ((new-object (do-map object))) + (unless (eq object new-object) + (setf (memref location 0) new-object))))))) + +(defun map-header-vals (function start-location end-location) "Map function over each potential pointer word between start-location and end-location." (macrolet ((scavenge-typep (x primary) @@ -42,12 +51,12 @@ (byte 8 8) (movitz:tag primary)))) `(= ,code ,x)))) - (do ((verbose *map-heap-words-verbose*) + (do ((verbose *map-header-vals-verbose*) (*scan-last* nil) ; Last scanned object, for debugging. (scan start-location (1+ scan))) ((>= scan end-location)) - (with-simple-restart (continue-map-heap-words - "Continue map-heap-words at location ~S." (1+ scan)) + (with-simple-restart (continue-map-header-vals + "Continue map-header-vals at location ~S." (1+ scan)) (let ((x (memref scan 0 :type :unsigned-byte16)) (x2 (memref scan 1 :type :unsigned-byte16))) (when verbose @@ -85,7 +94,7 @@ (code-vector (funobj-code-vector funobj)) (num-jumpers (funobj-num-jumpers funobj))) (check-type code-vector code-vector) - (map-heap-words function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name + (map-header-vals function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name (let ((new-code-vector (funcall function code-vector scan))) (check-type new-code-vector code-vector) (unless (eq code-vector new-code-vector) @@ -148,142 +157,143 @@ (setf (memref scan 0) new))))))))) (values)) -(defun map-stack-words (function stack start-frame) +(defun map-stack-vector (function stack start-frame &optional (map-region #'map-header-vals)) "Map function over the potential pointer words of a stack, starting at the start-stack-frame location." - (loop with next-frame with next-nether-frame - for nether-frame = start-frame then (or next-nether-frame frame) - and frame = (stack-frame-uplink stack start-frame) then (or next-frame - (stack-frame-uplink stack frame)) - while (plusp frame) - do (setf next-frame nil next-nether-frame nil) - do (flet ((scavenge-funobj-code-vector (funobj) - "Funobj 0 is assumed to be the DIT code-vector." - (if (eq 0 funobj) - (symbol-value 'default-interrupt-trampoline) - (funobj-code-vector funobj)))) - (let ((funobj (funcall function (stack-frame-funobj stack frame) frame))) - ;; If nether-frame is a DIT-frame, there are 4 more words to be skipped. - (when (eq 0 (stack-frame-ref stack nether-frame -1)) - (incf nether-frame 4)) - (typecase funobj - ((or function null) - (assert (= 0 (funobj-frame-num-unboxed funobj))) - (map-heap-words function (+ nether-frame 2) frame)) - ((eql 0) ; A dit interrupt-frame? - (let* ((dit-frame frame) - (casf-frame (dit-frame-casf stack dit-frame))) - ;; 1. Scavenge the dit-frame - (cond - ((let ((atomically (dit-frame-ref stack dit-frame :atomically-continuation - :unsigned-byte32))) - (and (not (= 0 atomically)) - (= 0 (ldb (byte 2 0) atomically)))) - ;; Interrupt occurred inside an (non-pf) atomically, so none of the - ;; registers are active. - (map-heap-words function (+ nether-frame 2) - (+ dit-frame 1 (dit-frame-index :tail-marker)))) - ((logbitp 10 (dit-frame-ref stack dit-frame :eflags :unsigned-byte32)) - ;; DF flag was 1, so EAX and EDX are not GC roots. - #+ignore (warn "Interrupt in uncommon mode at ~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) - (map-heap-words function ; Assume nothing in the dit-frame above the location .. - (+ nether-frame 2) ; ..of EDX holds pointers. - (+ dit-frame (dit-frame-index :edx)))) - (t #+ignore (warn "Interrupt in COMMON mode!") - (map-heap-words function ; Assume nothing in the dit-frame above the location .. - (+ nether-frame 2) ; ..of ECX holds pointers. - (+ dit-frame (dit-frame-index :ecx))))) - ;; 2. Pop to (dit-)frame's CASF - (setf nether-frame dit-frame - frame (dit-frame-casf stack frame)) - (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame)) - (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) - (interrupted-esp (dit-frame-esp stack dit-frame))) + (with-funcallable (map-region) + (loop with next-frame with next-nether-frame + for nether-frame = start-frame then (or next-nether-frame frame) + and frame = (stack-frame-uplink stack start-frame) then (or next-frame + (stack-frame-uplink stack frame)) + while (plusp frame) + do (setf next-frame nil next-nether-frame nil) + do (flet ((scavenge-funobj-code-vector (funobj) + "Funobj 0 is assumed to be the DIT code-vector." + (if (eq 0 funobj) + (symbol-value 'default-interrupt-trampoline) + (funobj-code-vector funobj)))) + (let ((funobj (funcall function (stack-frame-funobj stack frame) frame))) + ;; If nether-frame is a DIT-frame, there are 4 more words to be skipped. + (when (eq 0 (stack-frame-ref stack nether-frame -1)) + (incf nether-frame 4)) + (typecase funobj + ((or function null) + (assert (= 0 (funobj-frame-num-unboxed funobj))) + (map-region function (+ nether-frame 2) frame)) + ((eql 0) ; A dit interrupt-frame? + (let* ((dit-frame frame) + (casf-frame (dit-frame-casf stack dit-frame))) + ;; 1. Scavenge the dit-frame (cond - #+ignore - ((eq nil casf-funobj) - (warn "Scanning interrupt in PF: ~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32))) - ((or (eq 0 casf-funobj) - (typep casf-funobj 'function)) - (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj))) - ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. - (cond - ((< interrupted-ebp interrupted-esp) + ((let ((atomically (dit-frame-ref stack dit-frame :atomically-continuation + :unsigned-byte32))) + (and (not (= 0 atomically)) + (= 0 (ldb (byte 2 0) atomically)))) + ;; Interrupt occurred inside an (non-pf) atomically, so none of the + ;; registers are active. + (map-region function (+ nether-frame 2) + (+ dit-frame 1 (dit-frame-index :tail-marker)))) + ((logbitp 10 (dit-frame-ref stack dit-frame :eflags :unsigned-byte32)) + ;; DF flag was 1, so EAX and EDX are not GC roots. + #+ignore (warn "Interrupt in uncommon mode at ~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + (map-region function ; Assume nothing in the dit-frame above the location .. + (+ nether-frame 2) ; ..of EDX holds pointers. + (+ dit-frame (dit-frame-index :edx)))) + (t #+ignore (warn "Interrupt in COMMON mode!") + (map-region function ; Assume nothing in the dit-frame above the location .. + (+ nether-frame 2) ; ..of ECX holds pointers. + (+ dit-frame (dit-frame-index :ecx))))) + ;; 2. Pop to (dit-)frame's CASF + (setf nether-frame dit-frame + frame (dit-frame-casf stack frame)) + (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame)) + (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) + (interrupted-esp (dit-frame-esp stack dit-frame))) + (cond + #+ignore + ((eq nil casf-funobj) + (warn "Scanning interrupt in PF: ~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32))) + ((or (eq 0 casf-funobj) + (typep casf-funobj 'function)) + (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj))) + ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. (cond + ((< interrupted-ebp interrupted-esp) + (cond + ((location-in-object-p casf-code-vector + (dit-frame-ref stack dit-frame :eip :location)) + (warn "DIT at throw situation, in target EIP=~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + (map-region function interrupted-esp frame)) + ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack + dit-frame + :scratch1)) + (dit-frame-ref stack dit-frame :eip :location)) + (warn "DIT at throw situation, in thrower EIP=~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + (map-region function interrupted-esp frame)) + (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S" + interrupted-ebp + interrupted-esp)))) ((location-in-object-p casf-code-vector (dit-frame-ref stack dit-frame :eip :location)) - (warn "DIT at throw situation, in target EIP=~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) - (map-heap-words function interrupted-esp frame)) - ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack - dit-frame - :scratch1)) - (dit-frame-ref stack dit-frame :eip :location)) - (warn "DIT at throw situation, in thrower EIP=~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) - (map-heap-words function interrupted-esp frame)) - (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S" - interrupted-ebp - interrupted-esp)))) - ((location-in-object-p casf-code-vector - (dit-frame-ref stack dit-frame :eip :location)) - (cond - ((let ((x0-tag (ldb (byte 3 0) - (memref interrupted-esp 0 :type :unsigned-byte8)))) - (and (member x0-tag '(1 5 6 7)) - (location-in-object-p casf-code-vector - (memref interrupted-esp 0 :type :location)))) - ;; When code-vector migration is implemented... - (warn "Scanning at ~S X0 call ~S in ~S." - (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 0 :type :unsigned-byte32) - (funobj-name casf-funobj)) - #+ignore (map-heap-words function (+ interrupted-esp 1) frame) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 call in DIT-frame.")) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 1 -2))) - ((let ((x1-tag (ldb (byte 3 0) - (memref interrupted-esp 4 :type :unsigned-byte8)))) - (and (member x1-tag '(1 5 6 7)) - (location-in-object-p casf-code-vector - (memref interrupted-esp 4 :type :location)))) - ;; When code-vector migration is implemented... - (warn "Scanning at ~S X1 call ~S in ~S." - (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 4 :type :unsigned-byte32) - (funobj-name casf-funobj)) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 call in DIT-frame.")) - #+ignore (map-heap-words function (+ interrupted-esp 2) frame) + (cond + ((let ((x0-tag (ldb (byte 3 0) + (memref interrupted-esp 0 :type :unsigned-byte8)))) + (and (member x0-tag '(1 5 6 7)) + (location-in-object-p casf-code-vector + (memref interrupted-esp 0 :type :location)))) + ;; When code-vector migration is implemented... + (warn "Scanning at ~S X0 call ~S in ~S." + (dit-frame-ref stack dit-frame :eip :unsigned-byte32) + (memref interrupted-esp 0 :type :unsigned-byte32) + (funobj-name casf-funobj)) + (map-region function (+ interrupted-esp 1) frame) + (when (eq 0 (stack-frame-ref stack frame -1)) + (break "X1 call in DIT-frame.")) + (setf next-frame frame + next-nether-frame (+ interrupted-esp 1 -2))) + ((let ((x1-tag (ldb (byte 3 0) + (memref interrupted-esp 4 :type :unsigned-byte8)))) + (and (member x1-tag '(1 5 6 7)) + (location-in-object-p casf-code-vector + (memref interrupted-esp 4 :type :location)))) + ;; When code-vector migration is implemented... + (warn "Scanning at ~S X1 call ~S in ~S." + (dit-frame-ref stack dit-frame :eip :unsigned-byte32) + (memref interrupted-esp 4 :type :unsigned-byte32) + (funobj-name casf-funobj)) + (when (eq 0 (stack-frame-ref stack frame -1)) + (break "X1 call in DIT-frame.")) + (map-region function (+ interrupted-esp 2) frame) + (setf next-frame frame + next-nether-frame (+ interrupted-esp 2 -2))) + (t ;; Situation i. Nothing special on stack, scavenge frame normally. + ;; (map-region function interrupted-esp frame) + (setf next-frame frame + next-nether-frame (- interrupted-esp 2)) + ))) + ((eq casf-frame (memref interrupted-esp 0 :type :location)) + ;; Situation ii. esp(0)=CASF, esp(1)=code-vector + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 4 :type :location)) + + () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S" + casf-frame interrupted-esp interrupted-ebp) + (map-region function (+ interrupted-esp 2) frame) (setf next-frame frame next-nether-frame (+ interrupted-esp 2 -2))) - (t ;; Situation i. Nothing special on stack, scavenge frame normally. - ;; (map-heap-words function interrupted-esp frame) + (t ;; Situation iii. esp(0)=code-vector. + (assert (location-in-object-p casf-code-vector + (memref interrupted-esp 0 :type :location)) + () "Stack discipline situation iii. invariant broken. CASF=#x~X" + casf-frame) + (map-region function (+ interrupted-esp 1) frame) (setf next-frame frame - next-nether-frame (- interrupted-esp 2)) - ))) - ((eq casf-frame (memref interrupted-esp 0 :type :location)) - ;; Situation ii. esp(0)=CASF, esp(1)=code-vector - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 4 :type :location)) - - () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S" - casf-frame interrupted-esp interrupted-ebp) - #+ignore (map-heap-words function (+ interrupted-esp 2) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 2 -2))) - (t ;; Situation iii. esp(0)=code-vector. - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 :type :location)) - () "Stack discipline situation iii. invariant broken. CASF=#x~X" - casf-frame) - #+ignore (map-heap-words function (+ interrupted-esp 1) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 1 -2)))))) - (t (error "DIT-frame interrupted unknown CASF funobj: ~S" casf-funobj)))))) - (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj)))))) + next-nether-frame (+ interrupted-esp 1 -2)))))) + (t (error "DIT-frame interrupted unknown CASF funobj: ~S" casf-funobj)))))) + (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))))) (values))

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by Frode Vatvedt Fjeld 26 Nov '04

26 Nov '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv20993 Modified Files: los0-gc.lisp Log Message: Renamed the scavenging operators to map-header-vals and map-stack-vector. Added map-lisp-vals. Date: Fri Nov 26 15:59:19 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.43 movitz/losp/los0-gc.lisp:1.44 --- movitz/losp/los0-gc.lisp:1.43 Thu Nov 25 19:05:23 2004 +++ movitz/losp/los0-gc.lisp Fri Nov 26 15:59:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.43 2004/11/25 18:05:23 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.44 2004/11/26 14:59:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -304,8 +304,8 @@ (if (object-in-space-p oldspace x) nil x))) - (map-heap-words #'zap-oldspace 0 (malloc-end)) - (map-stack-words #'zap-oldspace nil (current-stack-frame)) + (map-header-vals #'zap-oldspace 0 (malloc-end)) + (map-stack-vector #'zap-oldspace nil (current-stack-frame)) (initialize-space oldspace) (values)))) @@ -354,16 +354,16 @@ forward-x)))))))) ;; Scavenge roots (dolist (range muerte::%memory-map-roots%) - (map-heap-words evacuator (car range) (cdr range))) - (map-stack-words evacuator nil (current-stack-frame)) + (map-header-vals evacuator (car range) (cdr range))) + (map-stack-vector evacuator nil (current-stack-frame)) ;; Scan newspace, Cheney style. (loop with newspace-location = (+ 2 (object-location newspace)) with scan-pointer = 2 as fresh-pointer = (space-fresh-pointer newspace) while (< scan-pointer fresh-pointer) - do (map-heap-words evacuator - (+ newspace-location scan-pointer) - (+ newspace-location (space-fresh-pointer newspace))) + do (map-header-vals evacuator + (+ newspace-location scan-pointer) + (+ newspace-location (space-fresh-pointer newspace))) (setf scan-pointer fresh-pointer)) ;; Consistency check.. @@ -394,13 +394,13 @@ new object: ~Z: ~S oldspace: ~Z, newspace: ~Z, i: ~D" old old new new oldspace newspace i)))))) - (map-heap-words (lambda (x y) - (declare (ignore y)) - (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space)) - (object-location x)) - (break "Seeing old object in values-vector: ~Z" x)) - x) - #x38 #xb8) + (map-header-vals (lambda (x y) + (declare (ignore y)) + (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space)) + (object-location x)) + (break "Seeing old object in values-vector: ~Z" x)) + x) + #x38 #xb8) (let* ((stack (%run-time-context-slot 'muerte::nursery-space)) (stack-start (- (length stack) (muerte::current-control-stack-depth)))) (do ((i 0 (+ i 3))) @@ -442,14 +442,14 @@ (handler-bind ((serious-condition (lambda (c) (when (and continuep - (find-restart 'muerte::continue-map-heap-words)) + (find-restart 'muerte::continue-map-header-vals)) (warn "Automatic continue from scanning error: ~A" c) - (invoke-restart 'muerte::continue-map-heap-words))))) + (invoke-restart 'muerte::continue-map-header-vals))))) (dolist (range muerte::%memory-map-roots%) - (map-heap-words #'searcher (car range) (cdr range))) + (map-header-vals #'searcher (car range) (cdr range))) (let ((nursery (%run-time-context-slot 'muerte::nursery-space))) - (map-heap-words #'searcher - (+ 4 (object-location nursery)) - (+ 4 (object-location nursery) (space-fresh-pointer nursery)))) - (map-stack-words #'searcher nil (current-stack-frame)))) + (map-header-vals #'searcher + (+ 4 (object-location nursery)) + (+ 4 (object-location nursery) (space-fresh-pointer nursery)))) + (map-stack-vector #'searcher nil (current-stack-frame)))) results))

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 26 Nov '04

26 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20976 Modified Files: packages.lisp Log Message: Renamed the scavenging operators to map-header-vals and map-stack-vector. Added map-lisp-vals. Date: Fri Nov 26 15:59:15 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.42 movitz/packages.lisp:1.43 --- movitz/packages.lisp:1.42 Wed Nov 24 17:22:43 2004 +++ movitz/packages.lisp Fri Nov 26 15:59:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.42 2004/11/24 16:22:43 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.43 2004/11/26 14:59:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1140,8 +1140,9 @@ #:package-object-internal-symbols #:package-object-external-symbols - #:map-heap-words - #:map-stack-words + #:map-lisp-vals + #:map-header-vals + #:map-stack-vector #:%memory-map% #:%memory-map-roots%

1 0

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

26 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv5256 Modified Files: pci.lisp Log Message: Now, scan-pci-bus prints some info about each device it can find on that bus. Date: Fri Nov 26 01:02:39 2004 Author: ffjeld Index: movitz/losp/x86-pc/pci.lisp diff -u movitz/losp/x86-pc/pci.lisp:1.6 movitz/losp/x86-pc/pci.lisp:1.7 --- movitz/losp/x86-pc/pci.lisp:1.6 Thu Nov 25 03:11:34 2004 +++ movitz/losp/x86-pc/pci.lisp Fri Nov 26 01:02:39 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Dec 14 22:33:42 2003 ;;;; -;;;; $Id: pci.lisp,v 1.6 2004/11/25 02:11:34 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.7 2004/11/26 00:02:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,64 +53,9 @@ (defvar *bios32-base* nil) (defvar *pcibios-entry* nil) -(defun find-bios32-pci () - (let ((bios32-base (find-bios32-base))) - (assert bios32-base "No bios32 found.") - (multiple-value-bind (eax ebx ecx edx) - (pci-far-call (memref-int bios32-base :offset 4) - :eax (pci-word "$PCI")) - (declare (ignore ecx)) - (ecase (ldb (byte 8 0) eax) - (#x80 (error "The PCI bios32 service isn't present.")) - (#x81 (error "The PCI bios32 service doesn't exist.")) - (#x00 (+ ebx edx)))))) - -(defun pci-bios-present () - (multiple-value-bind (eax ebx ecx edx cf) - (pci-far-call (find-bios32-pci) :eax #xb101) - (values (pci-string edx) - (ldb (byte 8 8) eax) ; AH: Present status - (ldb (byte 8 0) eax) ; AL: Hardware mechanism - (ldb (byte 8 8) ebx) ; BH: Interface Level Major Version - (ldb (byte 8 0) ebx) ; BL: Interface Level Minor Version - (ldb (byte 8 0) ecx)))) ; CL: Number of last PCI bus in the system - -(defun find-pci-device (vendor device &optional (index 0)) - (multiple-value-bind (eax ebx ecx edx cf) - (pci-far-call (find-bios32-pci) - :eax #xb102 - :ecx device - :edx vendor - :esi index) - (unless cf - (values (ldb (byte 8 8) ebx) ; Bus - (ldb (byte 5 3) ebx) ; Device - (ldb (byte 3 0) ebx) ; Function - (ecase (ldb (byte 8 8) eax) - (#x00 :successful) - (#x86 :device-not-found) - (#x83 :bad-vendor-id)))))) - -(defun find-pci-class-code (class-code &optional (index 0)) - (multiple-value-bind (eax ebx ecx edx cf) - (pci-far-call (find-bios32-pci) - :eax #xb103 - :ecx class-code - :esi index) - (declare (ignore ecx edx)) - (unless cf - (values (ldb (byte 8 8) ebx) ; Bus - (ldb (byte 5 3) ebx) ; Device - (ldb (byte 3 0) ebx) ; Function - (ecase (ldb (byte 8 8) eax) - (#x00 :successful) - (#x86 :device-not-found)))))) - - -(defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0)) +(defun pci-far-call (address &key (cs 8) (eax 0) (ebx 0) (ecx 0) (edx 0) (esi 0) (edi 0)) "Make a 'far call' to cs:address with the provided values for eax and ebx. -Returns the values of registers AL, EBX, ECX, and EDX, and status of CF. - (NB: For now only the lower 30 bits of registers are actually returned.) +Returns the values of registers EAX, EBX, ECX, and EDX, and status of CF. The stack discipline is broken during this call, so we disable interrupts in a somewhat feeble attempt to avoid trouble." (check-type address (unsigned-byte 32)) @@ -125,7 +70,7 @@ restart (:movl (:esp) :ebp) (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) - + (:pushl :edi) ; Save EDI so we can restore it later. (:load-lexical (:lexical-binding cs) :untagged-fixnum-ecx) (:pushl :ecx) ; Code segment (:load-lexical (:lexical-binding address) :untagged-fixnum-ecx) @@ -138,13 +83,17 @@ (:pushl :ecx) ; push EDX (:load-lexical (:lexical-binding esi) :untagged-fixnum-ecx) (:pushl :ecx) ; push ESI + (:load-lexical (:lexical-binding edi) :untagged-fixnum-ecx) + (:pushl :ecx) ; push EDI (:load-lexical (:lexical-binding ecx) :untagged-fixnum-ecx) + (:popl :edi) (:popl :esi) (:popl :edx) (:popl :ebx) (:popl :eax) (:call-segment (:esp)) - (:leal (:esp 8) :esp) + (:leal (:esp 8) :esp) ; Skip cs:address + (:popl :edi) ; First of all, restore EDI! (:locally (:movl :edi (:edi (:edi-offset values) 8))) (:jnc 'cf=0) (:locally (:pushl (:edi (:edi-offset t-symbol)))) @@ -171,3 +120,153 @@ ;; Exit atomical-mode (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) (:leal (:esp 16) :esp)))) + +(defun find-bios32-pci () + (let ((bios32-base (find-bios32-base))) + (assert bios32-base "No bios32 found.") + (multiple-value-bind (eax ebx ecx edx) + (pci-far-call (memref-int bios32-base :offset 4) + :eax (pci-word "$PCI")) + (declare (ignore ecx)) + (ecase (ldb (byte 8 0) eax) + (#x80 (error "The PCI bios32 service isn't present.")) + (#x81 (error "The PCI bios32 service doesn't exist.")) + (#x00 (+ ebx edx)))))) + +(defun pci-bios-present () + (multiple-value-bind (eax ebx ecx edx cf) + (pci-far-call (find-bios32-pci) :eax #xb101) + (values (pci-string edx) + (ldb (byte 8 8) eax) ; AH: Present status + (ldb (byte 8 0) eax) ; AL: Hardware mechanism + (ldb (byte 8 8) ebx) ; BH: Interface Level Major Version + (ldb (byte 8 0) ebx) ; BL: Interface Level Minor Version + (ldb (byte 8 0) ecx)))) ; CL: Number of last PCI bus in the system + +(defun find-pci-device (vendor device &optional (index 0)) + (multiple-value-bind (eax ebx ecx edx cf) + (pci-far-call (find-bios32-pci) + :eax #xb102 + :ecx device + :edx vendor + :esi index) + (unless cf + (values (ldb (byte 8 8) ebx) ; Bus + (ldb (byte 5 3) ebx) ; Device + (ldb (byte 3 0) ebx) ; Function + (ecase (ldb (byte 8 8) eax) + (#x00 :successful) + (#x86 :device-not-found) + (#x83 :bad-vendor-id)))))) + +(defun find-pci-class-code (class-code &optional (index 0)) + (multiple-value-bind (eax ebx ecx edx cf) + (pci-far-call (find-bios32-pci) + :eax #xb103 + :ecx class-code + :esi index) + (declare (ignore ecx edx)) + (unless cf + (values (ldb (byte 8 8) ebx) ; Bus + (ldb (byte 5 3) ebx) ; Device + (ldb (byte 3 0) ebx) ; Function + (pci-return-code eax))))) + +(defun pci-return-code (code) + (ecase (ldb (byte 8 8) code) + (#x00 :successful) + (#x81 :function-not-supported) + (#x83 :bad-vendor-id) + (#x86 :device-not-found) + (#x87 :bad-register-number))) + +(defun pci-location (bus device function) + "Compute 16-bit location from bus, device, and function numbers." + (dpb bus (byte 8 8) (dpb device (byte 5 3) (ldb (byte 3 0) function)))) + +(defun pci-class (code) + "Return the symbolic class-code sub-class code, and interface, if known." + (let* ((decode-table + #((:pre-pci2.0-device + :non-vga :vga-compatible) + (:mass-storage + :scsi :ide :floppy :ipi :raid) + (:network + :ethernet :token-ring :fddi :atm) + (:display + (:non-xga :vga :8514) :xga) + (:multimedia + :video :audio) + (:memory + :ram :flash) + (:bridge + :host/pci :pci/isa :pci/eisa :pci/micro-channel + :pci/pci :pci/pcmcia :pci/nubus :pci/cardbus) + (:simple-communication + (:serial-port :xt :16450 :16550) + (:parallel-port :generic :bi-directional :ecp-1.x)) + (:base-system-peripheral + (:pic :generic :isa :eisa) + (:dma :generic :isa :eisa) + (:timer :generic :isa :eisa) + (:rtc :generic :isa)) + (:input + :keyboard :digitizer :mouse) + (:docking-station + :generic) + (:processor + :386 :486 :pentium nil nil nil nil nil nil nil nil nil nil nil nil nil + :alpha nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + :powerpc nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil + :co-processor) + (:serial-bus + :firewire :access.bus :ssa :usb :fibre-channel))) + (class-code (ldb (byte 8 16) code)) + (class-table (and (< class-code (length decode-table)) + (svref decode-table class-code))) + (sub-class-table (nth (ldb (byte 8 8) code) (cdr class-table))) + (sub-class sub-class-table) + (sub-class-if (when (consp sub-class) + (setf sub-class (pop sub-class-table)) + (nth (ldb (byte 8 0) code) sub-class-table)))) + (values (car class-table) sub-class sub-class-if))) + +(defun pci-bios-read-configuration-word (bus device function register) + (multiple-value-bind (eax ebx ecx edx cf) + (pci-far-call (find-bios32-pci) + :eax #xb109 + :ebx (pci-location bus device function) + :edi register) + (declare (ignore ebx edx)) + (unless cf + (values (ldb (byte 16 0) ecx) (pci-return-code eax))))) + +(defun pci-bios-read-configuration-dword (bus device function register) + (multiple-value-bind (eax ebx ecx edx cf) + (pci-far-call (find-bios32-pci) + :eax #xb10a + :ebx (pci-location bus device function) + :edi register) + (declare (ignore ebx edx)) + (unless cf + (values ecx (pci-return-code eax))))) + +(defun scan-pci-bus (bus) + (loop for device from 0 to 31 + do (multiple-value-bind (vendor-id return-code) + (pci-bios-read-configuration-word bus device 0 0) + (when (and vendor-id + (not (= vendor-id #xffff)) + (eq :successful return-code)) + (let ((device-id (pci-bios-read-configuration-word bus device 0 2)) + (status (pci-bios-read-configuration-word bus device 0 6)) + (class-rev (pci-bios-read-configuration-dword bus device 0 8))) + (format *query-io* + "~&~D: Vendor #x~X, ID #x~X, Class #x~X, Rev. ~D, Status #x~X.~%" + device vendor-id device-id + (ldb (byte 24 8) class-rev) + (ldb (byte 8 0) class-rev) + status) + (format *query-io* " Class:~{ ~@[~A~]~}" + (multiple-value-list (pci-class (ldb (byte 24 8) class-rev)))))))) + (values)) \ No newline at end of file

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 25 Nov '04

25 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16107 Modified Files: primitive-functions.lisp Log Message: Renamed the malloc primitive functions. Date: Thu Nov 25 19:06:04 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.56 movitz/losp/muerte/primitive-functions.lisp:1.57 --- movitz/losp/muerte/primitive-functions.lisp:1.56 Thu Nov 25 17:45:47 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Nov 25 19:06:02 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.56 2004/11/25 16:45:47 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.57 2004/11/25 18:06:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -262,7 +262,7 @@ ;;;;;;;;;;;;;; Heap allocation protocol -(define-primitive-function get-cons-pointer () +(define-primitive-function cons-pointer () "Return in EAX the next object location with space for EAX words, with tag 6. Preserve ECX." (macrolet @@ -296,17 +296,17 @@ Preserve EAX and EBX." (macrolet ((do-it () - ;; Since get-cons-pointer is implemented as an (already committed) + ;; Since cons-pointer is implemented as an (already committed) ;; malloc, this is a no-op. `(with-inline-assembly (:returns :multiple-values) (:ret)))) (do-it))) -(define-primitive-function get-cons-pointer-non-pointer () +(define-primitive-function cons-non-pointer () "Return in EAX the next object location with space for EAX non-pointer words, with tag 6. Preserve ECX." (with-inline-assembly (:returns :multiple-values) - (:locally (:jmp (:edi (:edi-offset get-cons-pointer)))))) + (:locally (:jmp (:edi (:edi-offset cons-pointer)))))) (define-primitive-function cons-commit-non-pointer () "Return in EAX the next object location with space for EAX non-pointer words, with tag 6. @@ -314,11 +314,11 @@ (with-inline-assembly (:returns :multiple-values) (:locally (:jmp (:edi (:edi-offset cons-commit)))))) -(define-primitive-function get-cons-pointer-non-header () +(define-primitive-function cons-non-header () "Return in EAX the next object location with space for EAX non-pointer words, with tag 6. Preserve ECX." (with-inline-assembly (:returns :multiple-values) - (:locally (:jmp (:edi (:edi-offset get-cons-pointer)))))) + (:locally (:jmp (:edi (:edi-offset cons-pointer)))))) (define-primitive-function cons-commit-non-header () "Return in EAX the next object location with space for EAX non-pointer words, with tag 6.

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 25 Nov '04

25 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16064 Modified Files: integers.lisp Log Message: Renamed the malloc primitive functions. Date: Thu Nov 25 19:05:49 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.103 movitz/losp/muerte/integers.lisp:1.104 --- movitz/losp/muerte/integers.lisp:1.103 Wed Nov 24 11:08:41 2004 +++ movitz/losp/muerte/integers.lisp Thu Nov 25 19:05:48 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.103 2004/11/24 10:08:41 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.104 2004/11/25 18:05:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -526,7 +526,7 @@ (:leal ((:ecx 1) ,(* 1 movitz:+movitz-fixnum-factor+)) :eax) ; Number of words - (:call-local-pf get-cons-pointer) + (:call-local-pf cons-pointer) (:load-lexical (:lexical-binding y) :ebx) ; bignum (:movzxw (:ebx (:offset movitz-bignum length)) :ecx) (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) @@ -557,7 +557,7 @@ (:subl #x40000 (:eax ,movitz:+other-type-offset+)) (:subl ,movitz:+movitz-fixnum-factor+ :ecx) no-expansion - (:call-local-pf cons-commit) + (:call-local-pf cons-commit-non-pointer) (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) (:leal (:esp 16) :esp) @@ -607,7 +607,7 @@ (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) ;; Now inside atomically section. - (:call-local-pf get-cons-pointer) + (:call-local-pf cons-non-pointer) (:load-lexical (:lexical-binding y) :ebx) ; bignum (:movzxw (:ebx (:offset movitz-bignum length)) :ecx) (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) @@ -658,7 +658,7 @@ (:addl #x40000 (:eax ,movitz:+other-type-offset+)) (:addl ,movitz:+movitz-fixnum-factor+ :ecx) no-expansion - (:call-local-pf cons-commit) + (:call-local-pf cons-commit-non-pointer) (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) (:leal (:esp 16) :esp) pfix-pbig-done) @@ -1080,7 +1080,7 @@ (:leal (:eax :ebx ,(* 4 (+ 31 32))) :eax) (:andl ,(logxor #xffffffff (* 31 4)) :eax) (:shrl 5 :eax) - (:call-local-pf get-cons-pointer) ; New bignum into EAX + (:call-local-pf cons-non-pointer) ; New bignum into EAX (:load-lexical (:lexical-binding y) :ebx) ; bignum (:movl (:ebx ,movitz:+other-type-offset+) :ecx) @@ -1121,7 +1121,7 @@ (:movl :ebx :eax) (:movl :edi :edx) (:cld) ; EAX, EDX, and ESI are GC roots again. - (:call-local-pf cons-commit) + (:call-local-pf cons-commit-non-pointer) (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) (:leal (:esp 16) :esp) (:compile-form (:result-mode :ebx) x) @@ -1255,7 +1255,7 @@ (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) ;; Now inside atomically section. - (:call-local-pf get-cons-pointer) ; New bignum into EAX + (:call-local-pf cons-non-pointer) ; New bignum into EAX (:store-lexical (:lexical-binding r) :eax :type bignum) ; XXX breaks GC invariant! (:compile-form (:result-mode :ebx) number) @@ -1307,7 +1307,7 @@ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) (:jmp 'fixnum-result) ; don't commit the bignum no-more-shrinkage - (:call-local-pf cons-commit) + (:call-local-pf cons-commit-non-pointer) fixnum-result ;; Exit atomically block. (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) @@ -1772,7 +1772,7 @@ (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) ;; Now inside atomically section. - (:call-local-pf get-cons-pointer) + (:call-local-pf cons-non-pointer) (:shll 16 :ecx) (:orl ,(movitz:tag :bignum 0) :ecx) (:movl :ecx (:eax ,movitz:+other-type-offset+)) @@ -1780,7 +1780,7 @@ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* 1 movitz:+movitz-fixnum-factor+)) ; add 1 for header. :ecx) - (:call-local-pf cons-commit) + (:call-local-pf cons-commit-non-pointer) (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) (:leal (:esp 16) :esp) ;; Have fresh bignum in EAX, now fill it with ones. @@ -1982,7 +1982,7 @@ ;; Now add 1 for index->size, 1 for header, and 1 for tmp storage before shift. (:addl ,(* 3 movitz:+movitz-fixnum-factor+) :eax) (:pushl :eax) - (:call-local-pf get-cons-pointer) + (:call-local-pf cons-non-pointer) ;; (:store-lexical (:lexical-binding r) :eax :type t) (:popl :ecx) (:subl ,(* 2 movitz:+movitz-fixnum-factor+) :ecx) ; for tmp storage and header. @@ -2088,7 +2088,7 @@ (:movl :ebx :eax) (:leal (:ecx ,movitz:+movitz-fixnum-factor+) :ecx) - (:call-local-pf cons-commit) + (:call-local-pf cons-commit-non-pointer) return-fixnum (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) (:leal (:esp 16) :esp)

1 0