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

[movitz-cvs] CVS update: movitz/losp/lib/misc.lisp
by Frode Vatvedt Fjeld 24 Nov '04

24 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv4647 Modified Files: misc.lisp Log Message: Wrote add-u16-ones-complement for IP checksumming. Date: Wed Nov 24 11:05:47 2004 Author: ffjeld Index: movitz/losp/lib/misc.lisp diff -u movitz/losp/lib/misc.lisp:1.5 movitz/losp/lib/misc.lisp:1.6 --- movitz/losp/lib/misc.lisp:1.5 Sat Aug 14 19:52:35 2004 +++ movitz/losp/lib/misc.lisp Wed Nov 24 11:05:47 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon May 12 17:13:31 2003 ;;;; -;;;; $Id: misc.lisp,v 1.5 2004/08/14 17:52:35 ffjeld Exp $ +;;;; $Id: misc.lisp,v 1.6 2004/11/24 10:05:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -62,6 +62,32 @@ sum (packet-ref (1+ i)) into lo finally (return (+ lo (ash hi 8)))) (ash (packet-ref (1- end)) 8)))))))) + +(defun add-u16-ones-complement (&rest integers) + (numargs-case + (1 (x) + (if (= 0 x) + #xffff + (ldb (byte 16 0) x))) + (2 (x y) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) x y) + (:andl #.(cl:* movitz:+movitz-fixnum-factor+ #xffff) :eax) + (:andl #.(cl:* movitz:+movitz-fixnum-factor+ #xffff) :ebx) + (:addl :ebx :eax) + (:jz '(:sub-program (fix-zero) + (:movl #.(cl:* movitz:+movitz-fixnum-factor+ #xffff) :eax) + (:jmp 'done))) + (:testl #.(cl:* movitz:+movitz-fixnum-factor+ #x10000) :eax) + (:jz 'done) + (:addl #.movitz:+movitz-fixnum-factor+ :eax) + (:andl #.(cl:* movitz:+movitz-fixnum-factor+ #xffff) :eax) + (:jz 'fix-zero) + done)) + (t (&rest integers) + (declare (dynamic-extent integers)) + (reduce #'add-u16-ones-complement integers :initial-value 0)))) + (defstruct (counter-u32 (:constructor make-counter-u32-object)) lo hi)

1 0

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

24 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4610 Modified Files: parse.lisp Log Message: Just indentation. Date: Wed Nov 24 11:02:59 2004 Author: ffjeld Index: movitz/parse.lisp diff -u movitz/parse.lisp:1.3 movitz/parse.lisp:1.4 --- movitz/parse.lisp:1.3 Mon Jan 19 12:23:41 2004 +++ movitz/parse.lisp Wed Nov 24 11:02:59 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.3 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.4 2004/11/24 10:02:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -122,24 +122,24 @@ ((and (symbolp (car program)) (eq (symbol-package (car program)) from-package)) (cons (translate-symbol (car program)) - (muerte::translate-program (rest program) from-package to-package - :when when - :remove-double-quotes-p remove-double-quotes-p - :quote-symbol quote-symbol))) + (muerte::translate-program (cdr program) from-package to-package + :when when + :remove-double-quotes-p remove-double-quotes-p + :quote-symbol quote-symbol))) ((consp (car program)) (cons (muerte::translate-program (car program) from-package to-package - :when when - :remove-double-quotes-p remove-double-quotes-p - :quote-symbol quote-symbol) + :when when + :remove-double-quotes-p remove-double-quotes-p + :quote-symbol quote-symbol) (muerte::translate-program (cdr program) from-package to-package - :when when - :remove-double-quotes-p remove-double-quotes-p - :quote-symbol quote-symbol))) + :when when + :remove-double-quotes-p remove-double-quotes-p + :quote-symbol quote-symbol))) (t (cons (car program) (muerte::translate-program (cdr program) from-package to-package - :when when - :remove-double-quotes-p remove-double-quotes-p - :quote-symbol quote-symbol))))))) + :when when + :remove-double-quotes-p remove-double-quotes-p + :quote-symbol quote-symbol))))))) (defun decode-normal-lambda-list (lambda-list &optional host-symbols-p) "3.4.1 Ordinary Lambda Lists.

1 0

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

24 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4591 Modified Files: compiler.lisp Log Message: Fix detection of unused variables. Date: Wed Nov 24 11:02:43 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.116 movitz/compiler.lisp:1.117 --- movitz/compiler.lisp:1.116 Tue Nov 23 17:10:17 2004 +++ movitz/compiler.lisp Wed Nov 24 11:02:42 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.116 2004/11/23 16:10:17 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.117 2004/11/24 10:02:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2772,7 +2772,7 @@ This function is factored out from assign-bindings." (let* ((count-init-pc (gethash binding var-counts)) (count (car count-init-pc)) - (init-pc (cdr count-init-pc))) + (init-pc (second count-init-pc))) ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc) (cond ((binding-lended-p binding) @@ -2845,13 +2845,20 @@ (check-type function-env function-env) ;; (print-code 'discover code) (let ((var-counter (make-hash-table :test #'eq :size 40))) - (labels ((take-note-of-binding (binding &optional storep init-pc) + (labels ((record-binding-used (binding) (let ((count-init-pc (or (gethash binding var-counter) (setf (gethash binding var-counter) - (cons 0 nil))))) + (list 0 nil t))))) + (setf (third count-init-pc) t) + (when (typep binding 'forwarding-binding) + (record-binding-used (forwarding-binding-target binding))))) + (take-note-of-binding (binding &optional storep init-pc) + (let ((count-init-pc (or (gethash binding var-counter) + (setf (gethash binding var-counter) + (list 0 nil t))))) (when init-pc - (assert (not (cdr count-init-pc))) - (setf (cdr count-init-pc) init-pc)) + (assert (not (second count-init-pc))) + (setf (second count-init-pc) init-pc)) (unless storep (unless (eq binding (binding-target binding)) ;; (break "ewfew: ~S" (gethash (binding-target binding) var-counter)) @@ -2902,6 +2909,8 @@ (take-note-of-binding init-with-register))))) (t (mapcar #'take-note-of-binding (find-read-bindings instruction)) + (mapcar #'record-binding-used ; This is just concerning "unused variable" + (find-used-bindings instruction)) ; warnings! (let ((store-binding (find-written-binding-and-type instruction))) (when store-binding (take-note-of-binding store-binding t))) @@ -2953,13 +2962,13 @@ (prog1 nil ; may need lending-cons (setf (new-binding-location binding frame-map) `(:argument-stack ,(function-argument-argnum binding))))) - ((not (plusp (or (car (gethash binding var-counts)) 0))) - (prog1 t - (unless (or (movitz-env-get variable 'ignore nil env nil) - (movitz-env-get variable 'ignorable nil env nil) - (typep binding 'hidden-rest-function-argument)) - (warn "Unused variable: ~S" - (binding-name binding)))))) + ((unless (or (movitz-env-get variable 'ignore nil env nil) + (movitz-env-get variable 'ignorable nil env nil) + (typep binding 'hidden-rest-function-argument) + (third (gethash binding var-counts))) + (warn "Unused variable: ~S" + (binding-name binding)))) + ((not (plusp (or (car (gethash binding var-counts)) 0))))) collect binding)) (bindings-fun-arg-sorted (when (eq env function-env) @@ -2987,7 +2996,7 @@ (located-binding (let* ((count-init (gethash b var-counts)) (count (car count-init)) - (init-pc (cdr count-init))) + (init-pc (second count-init))) (if (not (and count init-pc)) 50 (truncate @@ -5924,6 +5933,9 @@ (defvar *extended-code-find-read-binding* (make-hash-table :test #'eq)) +(defvar *extended-code-find-used-bindings* + (make-hash-table :test #'eq)) + (defmacro define-find-read-bindings (name lambda-list &body body) (let ((defun-name (intern (with-standard-io-syntax @@ -5935,6 +5947,28 @@ (cdr instruction) ,@body))))) +(defmacro define-find-used-bindings (name lambda-list &body body) + (let ((defun-name (intern + (with-standard-io-syntax + (format nil "~A-~A" 'find-used-bindings name))))) + `(progn + (setf (gethash ',name *extended-code-find-used-bindings*) ',defun-name) + (defun ,defun-name (instruction) + (destructuring-bind ,lambda-list + (cdr instruction) + ,@body))))) + +(defun find-used-bindings (extended-instruction) + "Return zero, one or two bindings that this instruction reads." + (when (listp extended-instruction) + (let* ((operator (car extended-instruction)) + (finder (or (gethash operator *extended-code-find-used-bindings*) + (gethash operator *extended-code-find-read-binding*)))) + (when finder + (let ((result (funcall finder extended-instruction))) + (check-type result list "a list of read bindings") + result))))) + (defun find-read-bindings (extended-instruction) "Return zero, one or two bindings that this instruction reads." (when (listp extended-instruction) @@ -6417,6 +6451,11 @@ x)) (list term0 term1) )))) + +(define-find-used-bindings :add (term0 term1 destination) + (if (bindingp destination) + (list term0 term1 destination) + (list term0 term1))) (define-find-read-bindings :add (term0 term1 destination) (declare (ignore destination))

1 0

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

23 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19556 Modified Files: arrays.lisp Log Message: Fixed the array constructors to deal correctly with :fill-pointer t. Date: Tue Nov 23 20:30:24 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.47 movitz/losp/muerte/arrays.lisp:1.48 --- movitz/losp/muerte/arrays.lisp:1.47 Sun Nov 7 22:07:59 2004 +++ movitz/losp/muerte/arrays.lisp Tue Nov 23 20:30:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.47 2004/11/07 21:07:59 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.48 2004/11/23 19:30:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -632,144 +632,149 @@ `(funcall%unsafe ,writer ,store-var ,@args) `(funcall%unsafe ,reader ,@args)))) -(defun make-basic-vector%character (dimension fill-pointer initial-element initial-contents) - (check-type dimension (and fixnum (integer 0 *))) - (let* ((words (+ 2 (truncate (+ dimension 3) 4))) +(defun make-basic-vector%character (length fill-pointer initial-element initial-contents) + (check-type length (and fixnum (integer 0 *))) + (let* ((words (+ 2 (truncate (+ length 3) 4))) (array (macrolet ((do-it () `(with-non-pointer-allocation-assembly (words :fixed-size-p t :object-register :eax) - (:load-lexical (:lexical-binding dimension) :ecx) + (:load-lexical (:lexical-binding length) :ecx) (:movl ,(movitz:basic-vector-type-tag :character) (:eax (:offset movitz-basic-vector type))) (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) (do-it)))) (cond - (fill-pointer + ((integerp fill-pointer) (setf (fill-pointer array) fill-pointer)) - ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimension))) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) (cond (initial-element (check-type initial-element character) - (dotimes (i dimension) + (dotimes (i length) (setf (char array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%u32 (dimension fill-pointer initial-element initial-contents) - (check-type dimension (and fixnum (integer 0 *))) - (let* ((words (+ 2 dimension)) +(defun make-basic-vector%u32 (length fill-pointer initial-element initial-contents) + (check-type length (and fixnum (integer 0 *))) + (let* ((words (+ 2 length)) (array (macrolet ((do-it () `(with-non-pointer-allocation-assembly (words :fixed-size-p t :object-register :eax) - (:load-lexical (:lexical-binding dimension) :ecx) + (:load-lexical (:lexical-binding length) :ecx) (:movl ,(movitz:basic-vector-type-tag :u32) (:eax (:offset movitz-basic-vector type))) (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) (do-it)))) (cond - (fill-pointer + ((integerp fill-pointer) (setf (fill-pointer array) fill-pointer)) - ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimension))) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) (cond (initial-element ;; (check-type initial-element (unsigned-byte 32)) - (dotimes (i dimension) + (dotimes (i length) (setf (u32ref%unsafe array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%u8 (dimension fill-pointer initial-element initial-contents) - (check-type dimension (and fixnum (integer 0 *))) - (let* ((words (+ 2 (truncate (+ dimension 3) 4))) +(defun make-basic-vector%u8 (length fill-pointer initial-element initial-contents) + (check-type length (and fixnum (integer 0 *))) + (let* ((words (+ 2 (truncate (+ length 3) 4))) (array (macrolet ((do-it () `(with-non-pointer-allocation-assembly (words :fixed-size-p t :object-register :eax) - (:load-lexical (:lexical-binding dimension) :ecx) + (:load-lexical (:lexical-binding length) :ecx) (:movl ,(movitz:basic-vector-type-tag :u8) (:eax (:offset movitz-basic-vector type))) (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) (do-it)))) (cond - (fill-pointer + ((integerp fill-pointer) (setf (fill-pointer array) fill-pointer)) - ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimension))) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) (cond (initial-element (check-type initial-element (unsigned-byte 8)) - (dotimes (i dimension) + (dotimes (i length) (setf (u8ref%unsafe array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%bit (dimension fill-pointer initial-element initial-contents) - (check-type dimension (and fixnum (integer 0 *))) - (let* ((words (+ 2 (truncate (+ dimension 31) 32))) +(defun make-basic-vector%bit (length fill-pointer initial-element initial-contents) + (check-type length (and fixnum (integer 0 *))) + (let* ((words (+ 2 (truncate (+ length 31) 32))) (array (macrolet ((do-it () `(with-non-pointer-allocation-assembly (words :fixed-size-p t :object-register :eax) - (:load-lexical (:lexical-binding dimension) :ecx) + (:load-lexical (:lexical-binding length) :ecx) (:movl ,(movitz:basic-vector-type-tag :bit) (:eax (:offset movitz-basic-vector type))) (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) (do-it)))) (cond - (fill-pointer + ((integerp fill-pointer) (setf (fill-pointer array) fill-pointer)) - ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimension))) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) (cond (initial-element (check-type initial-element bit) - (dotimes (i dimension) + (dotimes (i length) (setf (aref array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%code (dimension fill-pointer initial-element initial-contents) - (check-type dimension (and fixnum (integer 0 *))) - (let* ((words (+ 2 (truncate (+ dimension 3) 4))) +(defun make-basic-vector%code (length fill-pointer initial-element initial-contents) + (check-type length (and fixnum (integer 0 *))) + (let* ((words (+ 2 (truncate (+ length 3) 4))) (array (macrolet ((do-it () `(with-non-pointer-allocation-assembly (words :fixed-size-p t :object-register :eax) - (:load-lexical (:lexical-binding dimension) :ecx) + (:load-lexical (:lexical-binding length) :ecx) (:movl ,(movitz:basic-vector-type-tag :code) (:eax (:offset movitz-basic-vector type))) (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) (do-it)))) (cond - (fill-pointer + ((integerp fill-pointer) (setf (fill-pointer array) fill-pointer)) - ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimension))) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) (cond (initial-element (check-type initial-element (unsigned-byte 8)) - (dotimes (i dimension) + (dotimes (i length) (setf (u8ref%unsafe array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%t (dimension fill-pointer initial-element initial-contents) - (check-type dimension (and fixnum (integer 0 *))) - (let* ((words (+ 2 dimension)) +(defun make-basic-vector%t (length fill-pointer initial-element initial-contents) + (check-type length (and fixnum (integer 0 *))) + (let* ((words (+ 2 length)) (array (macrolet ((do-it () `(with-allocation-assembly (words :fixed-size-p t :object-register :eax) - (:load-lexical (:lexical-binding dimension) :ecx) + (:load-lexical (:lexical-binding length) :ecx) (:movl ,(movitz:basic-vector-type-tag :any-t) (:eax (:offset movitz-basic-vector type))) (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))) @@ -785,17 +790,14 @@ ))) (do-it)))) (cond - (fill-pointer + ((integerp fill-pointer) (setf (fill-pointer array) fill-pointer)) - ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimension))) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) (cond (initial-contents - (replace array initial-contents)) - #+ignore - (initial-element - (dotimes (i dimension) - (setf (svref%unsafe array i) initial-element)))) + (replace array initial-contents))) array)) (defun make-array (dimensions &key element-type initial-element initial-contents adjustable

1 0

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

23 Nov '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv18534 Modified Files: los0.lisp Log Message: Have install-internal-time set up a stupd sleep function. Date: Tue Nov 23 20:03:16 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.30 movitz/losp/los0.lisp:1.31 --- movitz/losp/los0.lisp:1.30 Thu Nov 18 18:58:50 2004 +++ movitz/losp/los0.lisp Tue Nov 23 20:03:15 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.30 2004/11/18 17:58:50 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.31 2004/11/23 19:03:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -46,9 +46,6 @@ (in-package muerte.init) -(defun xx (a b) - (eql b #x123456789)) - (defun test0 () (ash 1 -1000000000000)) @@ -72,7 +69,7 @@ (loop for x below 2 count (not (not (typep x t))))) (defun test4 () - (let ((a 1)) (if (not (/= a 0)) a 0))) + (let ((aa 1)) (if (not (/= aa 0)) aa 0))) (defun test-floppy () @@ -244,13 +241,6 @@ (break "xfuncall:~{ ~S~^,~}" args) (values)) -(defun xx () - (format t "wefewf") - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:sbbl :edx :edx) - (:andl :edx :ecx) - (:leal (:edx :ecx 1) :ecx))) - (defun xfoo (f) (do-check-esp (multiple-value-bind (a b c d) @@ -545,8 +535,11 @@ (print 'hello-cleanup))) (defun test-cons (x) - (let ((c (cons x x))) - (cdr c))) + (let ((cc (cons x x))) + (cdr cc))) + +(defun xx (x) + (eql nil x)) (defun test-fixed (x y z) (warn "x: ~W, y: ~W, z: ~W" x y z)) @@ -732,7 +725,7 @@ (defclass pie2 (food) ((filling :accessor pie-filling :initarg :filling - :initform nil))) + ))) (defmethod cook ((p (eql 'pie))) (warn "Won't really cook a symbolic pie!") @@ -796,7 +789,7 @@ (defun init-nano-sleep () (setf *cpu-frequency-mhz* - (truncate (assess-cpu-frequency) 100))) + (truncate (assess-cpu-frequency) 976))) (defun nano-sleep (nano-seconds) (let* ((t0 (read-time-stamp-counter)) @@ -844,7 +837,16 @@ (read-time-stamp-counter) (+ (ash (ldb (byte 16 0) hi) 13) (ash lo -16))))) - (setf internal-time-units-per-second res))))))))) + (setf internal-time-units-per-second res)))))))) + (setf (symbol-function 'sleep) + (lambda (seconds) + ;; A stupid busy-waiting sleeper. + (check-type seconds (real 0 *)) + (let ((start-time (get-internal-run-time))) + (loop with start-time = (get-internal-run-time) + with end-time = (+ start-time (* seconds internal-time-units-per-second)) + while (< (get-internal-run-time) end-time))))) + (values)) ;;;(defun get-internal-run-time () @@ -1260,13 +1262,15 @@ (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16))))) (incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16)))))) -(defun mumbojumbo () - (with-inline-assembly (:returns :multiple-values) - (:leave) - (:movl (:ebp -4) :esi) - (:break) - (:ret))) - +(defun mumbojumbo (x) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :untagged-fixnum-ecx) x) + (:movl 0 :eax) + (:cmpl -1 :ecx) + (:jno 'no-overflow) + (:movl 4 :eax) + no-overflow)) + (defun genesis () ;; (install-shallow-binding) (let ((extended-memsize 0)) @@ -1591,7 +1595,7 @@ (define-primitive-function dynamic-variable-lookup-shallow (symbol) "Load the dynamic value of SYMBOL into EAX." (with-inline-assembly (:returns :multiple-values) - (:movl (:eax (:offset movitz-symbol value)) :eax) + (:movl (:ebx (:offset movitz-symbol value)) :eax) (:ret))) (define-primitive-function dynamic-variable-store-shallow (symbol value)

1 0

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

23 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv7811 Modified Files: ip4.lisp Log Message: Use untyped (i.e. memref) accessors to packets. Date: Tue Nov 23 17:14:49 2004 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.7 movitz/losp/lib/net/ip4.lisp:1.8 --- movitz/losp/lib/net/ip4.lisp:1.7 Thu Oct 21 22:52:11 2004 +++ movitz/losp/lib/net/ip4.lisp Tue Nov 23 17:14:49 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.7 2004/10/21 20:52:11 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.8 2004/11/23 16:14:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,12 +25,23 @@ #:read-ip4-address #:ip4-address #:ip4-test - #:ip4-free)) - -(require :lib/net/arp) + #:ip4-free + #:*ip4-nic* + #:*ip4-ip*)) (in-package muerte.ip4) +(defvar *ip4-nic* nil) +(defvar *ip4-ip* nil) + +(defmacro ip4-ref (packet start offset type) + `(memref ,packet (+ (muerte:movitz-type-slot-offset 'movitz-basic-vector 'data) + ,start ,offset) + :endian :big + :type ,type)) + +(require :lib/net/arp) + (defclass ip4-stack () ((interface :initarg :interface @@ -62,10 +73,11 @@ (20 options)) (defun ip-protocol (packet &optional (start 14)) - (aref packet (+ start +ip-header-protocol+))) + (ip4-ref packet start +ip-header-protocol+ :unsigned-byte8)) (defun ip-header-length (packet &optional (start 14)) - (ldb (byte 4 0) (aref packet (+ start +ip-header-version-header-length+)))) + (ldb (byte 4 0) + (ip4-ref packet start +ip-header-version-header-length+ :unsigned-byte8))) (defun checksum-ok (x) (= #xffff @@ -160,8 +172,6 @@ (warn "Received unknown ARP packet of type ~D~@[ ~A~]" (arp-operation packet start) (integer-name 'arp-op (arp-operation packet start) nil))))) - - ;;; ICMP @@ -173,27 +183,27 @@ (8 echo-request)) (defun icmp-type (packet &optional (start 34)) - (aref packet start)) + (ip4-ref packet start 0 :unsigned-byte8)) (defun (setf icmp-type) (value packet &optional (start 34)) - (setf (aref packet start) value)) + (setf (ip4-ref packet start 0 :unsigned-byte8) + value)) (defun icmp-code (packet &optional (start 34)) - (aref packet (1+ start))) + (ip4-ref packet start 1 :unsigned-byte8)) (defun icmp-checksum (packet &optional (start 34)) - (bvref-u16 packet start 2)) + (ip4-ref packet start 2 :unsigned-byte16)) (defun icmp-identifier (packet &optional (start 34)) - (bvref-u16 packet start 4)) + (ip4-ref packet start 4 :unsigned-byte16)) (defun icmp-seqno (packet &optional (start 34)) - (bvref-u16 packet start 6)) + (ip4-ref packet start 6 :unsigned-byte16)) (defun (setf icmp-checksum) (value packet &optional (start 34)) - (setf (aref packet (+ start 2)) (ldb (byte 8 8) value) - (aref packet (+ start 3)) (ldb (byte 8 0) value)) - value) + (setf (ip4-ref packet start 2 :unsigned-byte16) + value)) (defmethod icmp-input ((stack ip4-stack) packet ip-start icmp-start) (named-integer-case icmp-type (icmp-type packet icmp-start) @@ -253,20 +263,20 @@ ;;;; UDP (defun udp-src-port (packet &optional (start 34)) - (bvref-u16 packet start 0)) + (ip4-ref packet start 0 :unsigned-byte16)) (defun (setf udp-src-port) (value packet &optional (start 34)) - (setf (bvref-u16 packet start 0) value)) + (setf (ip4-ref packet start 0 :unsigned-byte16) + value)) (defun udp-dst-port (packet &optional (start 34)) - (bvref-u16 packet start 2)) + (ip4-ref packet start 2 :unsigned-byte16)) (defun udp-length (packet &optional (start 34)) - (bvref-u16 packet start 4)) + (ip4-ref packet start 4 :unsigned-byte16)) (defun udp-checksum (packet &optional (start 34)) - (bvref-u16 packet start 6)) - + (ip4-ref packet start 6 :unsigned-byte16)) (defmethod udp-input ((stack ip4-stack) packet ip-start udp-start) (warn "Got UDP packet of length ~D from ~@v/ip4:pprint-ip4/." @@ -296,22 +306,24 @@ (5 urg)) (defun tcp-src-port (packet &optional (start 34)) - (bvref-u16 packet start +tcp-header-src-port+)) + (ip4-ref packet start +tcp-header-src-port+ :unsigned-byte16)) (defun tcp-dst-port (packet &optional (start 34)) - (bvref-u16 packet start +tcp-header-dst-port+)) + (ip4-ref packet start +tcp-header-dst-port+ :unsigned-byte16)) (defun tcp-header-length (packet &optional (start 34)) - (ldb (byte 4 4) (aref packet (+ start +tcp-header-flags-length+)))) + (ldb (byte 4 4) + (ip4-ref packet start +tcp-header-flags-length+ :unsigned-byte8))) (defun tcp-flags (packet &optional (start 34)) - (ldb (byte 6 0) (aref packet (+ start +tcp-header-flags-length+ 1)))) + (ldb (byte 6 0) + (ip4-ref packet start (+ +tcp-header-flags-length+ 1) :unsigned-byte8))) (defun tcp-window-size (packet &optional (start 34)) - (bvref-u16 packet start +tcp-header-window-size+)) + (ip4-ref packet start +tcp-header-window-size+ :unsigned-byte16)) (defun tcp-checksum (packet &optional (start 34)) - (bvref-u16 packet start +tcp-header-checksum+)) + (ip4-ref packet start +tcp-header-checksum+ :unsigned-byte16)) (defun print-flags (x set) (loop with first = t @@ -383,23 +395,23 @@ (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)))) +(defun ip4-init () + (unless *ip4-nic* + (let ((ethernet + (some #'muerte.x86-pc.ne2k:ne2k-probe + muerte.x86-pc.ne2k:+ne2k-probe-addresses+))) + (assert ethernet ethernet "No ethernet device.") + (setf *ip4-nic* ethernet))) + (unless *ip4-ip* + (setf *ip4-ip* (ip4-address :129.242.16.173))) + (values *ip4-nic* *ip4-ip*)) + +(defun ip4-test (&key (router #(129 242 16 1))) + (ip4-init) + (let ((ethernet *ip4-nic*) + (stack (make-instance 'ip4-stack + :interface *ip4-nic* + :address *ip4-ip*))) (when router (transmit (interface stack) (format-ethernet-packet (format-arp-request nil +arp-op-request+

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp
by Frode Vatvedt Fjeld 23 Nov '04

23 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv7788 Modified Files: ethernet.lisp Log Message: Use untyped (i.e. memref) accessors to packets. Date: Tue Nov 23 17:14:44 2004 Author: ffjeld Index: movitz/losp/lib/net/ethernet.lisp diff -u movitz/losp/lib/net/ethernet.lisp:1.4 movitz/losp/lib/net/ethernet.lisp:1.5 --- movitz/losp/lib/net/ethernet.lisp:1.4 Thu Feb 26 12:30:07 2004 +++ movitz/losp/lib/net/ethernet.lisp Tue Nov 23 17:14:40 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 17 15:25:31 2002 ;;;; -;;;; $Id: ethernet.lisp,v 1.4 2004/02/26 11:30:07 ffjeld Exp $ +;;;; $Id: ethernet.lisp,v 1.5 2004/11/23 16:14:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,6 +65,12 @@ ;;; Packet accessors +(defmacro packet-ref (packet start offset type) + `(memref ,packet (+ (muerte:movitz-type-slot-offset 'movitz-basic-vector 'data) + ,start ,offset) + :endian :big + :type ,type)) + (defun ether-destination (packet &optional (start 0)) (subseq packet start (+ start 6))) @@ -80,35 +86,31 @@ source) (defun ether-type (packet &optional (start 0)) - (bvref-u16 packet start 12) - #+ignore - (logior (ash (aref packet (+ start 12)) 8) - (aref packet (+ start 13)))) + (packet-ref packet start 12 :unsigned-byte16)) (defun (setf ether-type) (type packet &optional (start 0)) - (setf (aref packet (+ start 12)) (ldb (byte 8 8) type) - (aref packet (+ start 13)) (ldb (byte 8 0) type)) - type) + (setf (packet-ref packet start 12 :unsigned-byte16) + type)) (defun ether-802.3-p (packet &optional (start 0)) "Is the packet a 802.3 type packet?" (<= (ether-type packet start) #x5dc)) (defun ether-802.3-llc-type (packet &optional (start 0)) - (aref packet (+ start 16))) + (packet-ref packet start 16 :unsigned-byte8)) (defun ether-802.3-llc-dsap (packet &optional (start 0)) - (aref packet (+ start 14))) + (packet-ref packet start 14 :unsigned-byte8)) (defun ether-802.3-llc-ssap (packet &optional (start 0)) - (aref packet (+ start 15))) + (packet-ref packet start 15 :unsigned-byte8)) (defun ether-802.3-snap-p (packet &optional (start 0)) (and (ether-802.3-p packet) (= #xAA (ether-802.3-llc-ssap packet start)))) (defun ether-802.3-snap-type (packet &optional (start 0)) - (bvref-u16 packet start 20)) + (packet-ref packet start 20 :unsigned-byte16)) ;;;

1 0

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

23 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv7768 Modified Files: arp.lisp Log Message: Use untyped (i.e. memref) accessors to packets. Date: Tue Nov 23 17:14:33 2004 Author: ffjeld Index: movitz/losp/lib/net/arp.lisp diff -u movitz/losp/lib/net/arp.lisp:1.5 movitz/losp/lib/net/arp.lisp:1.6 --- movitz/losp/lib/net/arp.lisp:1.5 Thu Jul 22 02:58:50 2004 +++ movitz/losp/lib/net/arp.lisp Tue Nov 23 17:14:33 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.5 2004/07/22 00:58:50 ffjeld Exp $ +;;;; $Id: arp.lisp,v 1.6 2004/11/23 16:14:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,14 +45,11 @@ (+ start 28))) (setf packet (make-array +min-ethernet-frame-size+ :element-type '(unsigned-byte 8)))) - (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) - (aref packet (+ start 3)) (ldb (byte 8 0) prot-type) - (aref packet (+ start 4)) hard-size - (aref packet (+ start 5)) prot-size - (aref packet (+ start 6)) (ldb (byte 8 8) op) - (aref packet (+ start 7)) (ldb (byte 8 0) op)) + (setf (ip4-ref packet start 0 :unsigned-byte16) hard-type + (ip4-ref packet start 2 :unsigned-byte16) prot-type + (ip4-ref packet start 4 :unsigned-byte8) hard-size + (ip4-ref packet start 5 :unsigned-byte8) prot-size + (ip4-ref packet start 6 :unsigned-byte16) op) (replace packet sender-hardware-address :start1 (+ start 8) :end1 (+ start 14) @@ -72,35 +69,53 @@ (defun arp-operation (packet &optional (start 14)) - (bvref-u16 packet start 6)) + (ip4-ref packet start 6 :unsigned-byte16)) (defun arp-hard-type (packet &optional (start 14)) - (bvref-u16 packet start 0)) + (ip4-ref packet start 0 :unsigned-byte16)) (defun arp-prot-type (packet &optional (start 14)) - (bvref-u16 packet start 2)) - + (ip4-ref packet start 2 :unsigned-byte16)) (defvar *ne2000* nil) + +(defun arp-polling (ip &optional (waiter #'false)) + (loop with nic = *ip4-nic* + for packet = (muerte.ethernet:receive nic) + until (funcall waiter) + do (transmit nic + (format-ethernet-packet (format-arp-request nil +arp-op-request+ *ip4-ip* + (mac-address nic) ip) + (mac-address nic) + muerte.ethernet:+broadcast-address+ + muerte.ethernet:+ether-type-arp+)) + (when (and packet + (eq +ether-type-arp+ (ether-type packet)) + (eq +arp-op-reply+ (arp-operation packet)) + (not (mismatch packet ip :start1 28 :end1 32))) + (return (subseq packet 22 28))))) (defun test-arp (&optional (ip #(129 242 16 30)) (my-ip #(129 242 16 173)) - (device (or *ne2000* - #+ignore - (setf *ne2000* (some #'muerte.x86-pc.ne2k:ne2k-probe muerte.x86-pc.ne2k:+ne2k-probe-addresses+))))) + (device *ne2000*)) - (loop for packet = (muerte.ethernet:receive device) + (loop with ip = (ip4-address ip) and my-ip = (ip4-address my-ip) + for packet = (muerte.ethernet:receive device) with i = 9999 do (when (= (incf i) 10000) (setf i 0) (transmit device - (format-ethernet-packet (format-arp-request nil +arp-op-request+ my-ip (mac-address device) ip) + (format-ethernet-packet (format-arp-request nil +arp-op-request+ + my-ip (mac-address device) ip) (mac-address device) muerte.ethernet:+broadcast-address+ muerte.ethernet:+ether-type-arp+))) until (or (muerte.x86-pc.keyboard:poll-char) (when (and packet - (or (eq +ether-type-arp+ (ether-type packet)) (warn "not type")) - (or (eq +arp-op-reply+ (arp-operation packet)) (warn "not op")) - (or (not (mismatch packet ip :start1 28 :end1 32)) (warn "mismatch: ~S" (subseq packet 28 32)))) + (or (eq +ether-type-arp+ (ether-type packet)) + (warn "not type")) + (or (eq +arp-op-reply+ (arp-operation packet)) + (warn "not op")) + (or (not (mismatch packet ip :start1 28 :end1 32)) + (warn "mismatch: ~S" (subseq packet 28 32)))) (format t "The MAC of ~S is ~22/ethernet:pprint-mac/." ip packet) t))))

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 23 Nov '04

23 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7727 Modified Files: special-operators-cl.lisp Log Message: new-unbound-value Date: Tue Nov 23 17:12:27 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.37 movitz/special-operators-cl.lisp:1.38 --- movitz/special-operators-cl.lisp:1.37 Fri Nov 19 21:12:37 2004 +++ movitz/special-operators-cl.lisp Tue Nov 23 17:12:25 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.37 2004/11/19 20:12:37 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.38 2004/11/23 16:12:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -97,29 +97,36 @@ and do (incf (num-specials local-env)) ;; lexical... else collect - (compiler-values-bind (&code init-code &functional-p functional-p - &type type &returns init-register - &final-form final-form) - (compiler-call #'compile-form-to-register - :env init-env - :defaults all - :form init-form - :modify-accumulate let-modifies) - ;; (warn "prod: ~S, type: ~S" prod type) - (list var - init-form - init-code - functional-p - (let ((init-type (type-specifier-primary type))) - (assert init-type () - "The init-form ~S yielded the empty primary type!" type) - init-type) - (case init-register - (:non-local-exit :edi) - (t init-register)) - final-form)) - and do (movitz-env-add-binding local-env (make-instance 'located-binding - :name var))))) + (let ((binding (make-instance 'located-binding :name var))) + (movitz-env-add-binding local-env binding) + (compiler-values-bind (&code init-code &functional-p functional-p + &type type &returns init-register + &final-form final-form) + (compiler-call #'compile-form-to-register + :env init-env + :defaults all + :form init-form + :modify-accumulate let-modifies) +;;; ;; (warn "prod: ~S, type: ~S" prod type) +;;; (warn "var ~S init: ~S.." var init-form) +;;; (print-code 'init +;;; (compiler-call #'compile-form +;;; :env init-env +;;; :defaults all +;;; :form init-form +;;; :result-mode binding)) + (list var + init-form + init-code + functional-p + (let ((init-type (type-specifier-primary type))) + (assert init-type () + "The init-form ~S yielded the empty primary type!" type) + init-type) + (case init-register + (:non-local-exit :edi) + (t init-register)) + final-form)))))) (setf (stack-used local-env) (stack-used init-env)) (flet ((compile-body () @@ -834,7 +841,7 @@ ;; catcher (:locally (:pushl (:edi (:edi-offset dynamic-env)))) (:pushl ',label-set-name) - (:locally (:pushl (:edi (:edi-offset unbound-value)))) + (:locally (:pushl (:edi (:edi-offset unbound-function)))) (:pushl :ebp) (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) `((:init-lexvar ,save-esp-binding @@ -1109,7 +1116,7 @@ (:je '(:sub-program (,zero-specials) ;; Insert dummy binding (:pushl :edi) ; biding value - (:globally (:pushl (:edi (:edi-offset unbound-value)))) ; [[ binding tag ]] + (:pushl :edi) ; scratch (:pushl :edi) ; binding name (:pushl :esp) (:addl 4 :ecx) @@ -1117,7 +1124,7 @@ ,loop (:cmpl :edi :ebx) ; (endp symbols) (:je ',no-more-symbols) ; .. (go no-more-symbols) - (:globally (:movl (:edi (:edi-offset unbound-value)) :edx)) + (:globally (:movl (:edi (:edi-offset new-unbound-value)) :edx)) (:cmpl :edi :eax) ; (endp values) (:je ',no-more-values) ; .. (go no-more-values) (:movl (:eax -1) :edx) @@ -1272,7 +1279,7 @@ ,cleanup-entry ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation - (:locally (:movl (:edi (:edi-offset unbound-value)) :edx)) + (:locally (:movl (:edi (:edi-offset unbound-function)) :edx)) (:movl :edx (:esp 4)) ; not unwind-protect-tag (:movl ',continue-label (:esp 8)) ; new jumper index

1 0

[movitz-cvs] CVS update: movitz/procfs-image.lisp
by Frode Vatvedt Fjeld 23 Nov '04

23 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7639 Modified Files: procfs-image.lisp Log Message: Have with-bochs-image copy the ds-segment etc. from *image*. Date: Tue Nov 23 17:11:31 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.20 movitz/procfs-image.lisp:1.21 --- movitz/procfs-image.lisp:1.20 Fri Nov 12 15:41:10 2004 +++ movitz/procfs-image.lisp Tue Nov 23 17:11:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.20 2004/11/12 14:41:10 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.21 2004/11/23 16:11:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,6 +72,12 @@ (pid (bochs-parameter :pid ,path))) (procfs:with-procfs-attached (,procfs-var pid :direction :io) (let ((,image-var (make-instance 'bochs-image + :ds-segment-base (if (boundp '*previous-image*) + (image-ds-segment-base *previous-image*) + 0) + :cs-segment-base (if (boundp '*previous-image*) + (image-cs-segment-base *previous-image*) + 0) :pid pid :procfs ,procfs-var :stream (procfs:procfs-connection-mem-stream ,procfs-var)

1 0